# HG changeset patch # User Walther Neuper # Date 1282746007 -7200 # Node ID 22235e4dbe5f8d624548cfcfa699c55bf2a1faf9 # Parent a28b5fc129b77156ea8d34e4d9d05ab9bfbc7869 renamed isac's directories and Build_Isac.thy Scripts --> ProgLang ME --> Interpret IsacKnowledge --> Knowledge diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Build_Isac.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Build_Isac.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,103 @@ +(* Title: ~~~/isac/Isac_Mathengine.thy + Author: Walther Neuper, TU Graz + +$ cd /usr/local/Isabelle2009-1/src/Tools/isac +$ /usr/local/isabisac/bin/isabelle emacs Build_Isac.thy & +$ /usr/local/isabisac/bin/isabelle jedit Build_Isac.thy & + +12345678901234567890123456789012345678901234567890123456789012345678901234567890 + 10 20 30 40 50 60 70 80 +*) + +header {* Loading the isac mathengine *} + +theory Build_Isac +(*imports Complex_Main*) +imports Complex_Main "ProgLang/Script" + (*ListC, Tools, Script*) +begin + +ML {* +writeln "**** build the isac kernel = math-engine + Knowledge ***********"; +writeln "**** build the math-engine *************************************" *} + +ML {* Toplevel.debug := true; *} +use "library.sml" +use "calcelems.sml" +ML {* check_guhs_unique := true *} + +use "ProgLang/term.sml" +use "ProgLang/calculate.sml" +use "ProgLang/rewrite.sml" +use_thy"ProgLang/Script" +use "ProgLang/scrtools.sml" + +use "Interpret/mstools.sml" +use "Interpret/ctree.sml" +use "Interpret/ptyps.sml" +use "Interpret/generate.sml" +use "Interpret/calchead.sml" +use "Interpret/appl.sml" +use "Interpret/rewtools.sml" +use "Interpret/script.sml" +use "Interpret/solve.sml" +use "Interpret/inform.sml" +use "Interpret/mathengine.sml" + +use "xmlsrc/mathml.sml" +use "xmlsrc/datatypes.sml" +use "xmlsrc/pbl-met-hierarchy.sml" +use "xmlsrc/thy-hierarchy.sml" +use "xmlsrc/interface-xml.sml" + +use "Frontend/messages.sml" +use "Frontend/states.sml" +use "Frontend/interface.sml" + +use "print_exn_G.sml" +ML {* writeln "**** build math-engine complete **************************" *} + +ML {* writeln "**** build the Knowledge *********************************" *} +use_thy "Knowledge/Typefix" +use_thy "Knowledge/Descript" + +ML {* + +111; +*} + +use_thy "Knowledge/Atools" + + +ML {* +val str = "1234567890"; +*} + +(* +use_thy "Knowledge/Simplify" +use_thy "Knowledge/Poly" +use_thy "Knowledge/Rational" +use_thy "Knowledge/PolyMinus" +use_thy "Knowledge/Equation" +use_thy "Knowledge/LinEq" +use_thy "Knowledge/Root" +use_thy "Knowledge/RootEq" +use_thy "Knowledge/RatEq" +use_thy "Knowledge/RootRat" +use_thy "Knowledge/RootRatEq" +use_thy "Knowledge/PolyEq" +use_thy "Knowledge/Vect" +use_thy "Knowledge/Calculus" +use_thy "Knowledge/Trig" +use_thy "Knowledge/LogExp" +use_thy "Knowledge/Diff" +use_thy "Knowledge/DiffApp" +use_thy "Knowledge/Integrate" +use_thy "Knowledge/EqSystem" +use_thy "Knowledge/Biegelinie" +use_thy "Knowledge/AlgEin" +use_thy "Knowledge/Test" +use_thy "Knowledge/Isac" +*) +end + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/CLEANUP --- a/src/Tools/isac/CLEANUP Wed Aug 25 15:15:01 2010 +0200 +++ b/src/Tools/isac/CLEANUP Wed Aug 25 16:20:07 2010 +0200 @@ -21,7 +21,7 @@ rm *.tar* rm *.orig cd .. -cd FE-interface +cd Frontend rm *~ rm #* rm .#* diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/FE-interface/interface.sml --- a/src/Tools/isac/FE-interface/interface.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,843 +0,0 @@ -(* the interface between the isac-kernel and the java-frontend; - the isac-kernel holds calc-trees; stdout in XML-format. - authors: Walther Neuper 2002 - (c) due to copyright terms - -use"FE-interface/interface.sml"; -use"interface.sml"; -*) - -signature INTERFACE = - sig - val CalcTree : fmz list -> unit - val DEconstrCalcTree : calcID -> unit - val Iterator : calcID -> unit - val IteratorTEST : calcID -> iterID - val appendFormula : calcID -> cterm' -> unit - val autoCalculate : calcID -> auto -> unit - val checkContext : calcID -> pos' -> guh -> unit - val fetchApplicableTactics : calcID -> int -> pos' -> unit - val fetchProposedTactic : calcID -> unit - val applyTactic : calcID -> pos' -> tac -> unit - val getAccumulatedAsms : calcID -> pos' -> unit - val getActiveFormula : calcID -> unit - val getAssumptions : calcID -> pos' -> unit - val initContext : calcID -> ketype -> pos' -> unit - val getFormulaeFromTo : calcID -> pos' -> pos' -> int -> bool -> unit - val getTactic : calcID -> pos' -> unit - val interSteps : calcID -> pos' -> unit - val modifyCalcHead : calcID -> icalhd -> unit - val moveActiveCalcHead : calcID -> unit - val moveActiveDown : calcID -> unit - val moveActiveDownTEST : calcID -> unit - val moveActiveFormula : calcID -> pos' -> unit - val moveActiveLevelDown : calcID -> unit - val moveActiveLevelUp : calcID -> unit - val moveActiveRoot : calcID -> unit - val moveActiveRootTEST : calcID -> unit - val moveActiveUp : calcID -> unit - val moveCalcHead : calcID -> pos' -> unit - val moveDown : calcID -> pos' -> unit - val moveLevelDown : calcID -> pos' -> unit - val moveLevelUp : calcID -> pos' -> unit - val moveRoot : calcID -> unit - val moveUp : calcID -> pos' -> unit - val refFormula : calcID -> pos' -> unit - val replaceFormula : calcID -> cterm' -> unit - val resetCalcHead : calcID -> unit - val modelProblem : calcID -> unit - val refineProblem : calcID -> pos' -> guh -> unit - val setContext : calcID -> pos' -> guh -> unit - val setMethod : calcID -> metID -> unit - val setNextTactic : calcID -> tac -> unit - val setProblem : calcID -> pblID -> unit - val setTheory : calcID -> thyID -> unit - end - - -(*------------------------------------------------------------------*) -structure interface : INTERFACE = -struct -(*------------------------------------------------------------------*) - -(*.encode "Isabelle"-strings as seen by the user to the - format accepted by Isabelle. - encode "^" ---> "^^^"; see IsacKnowledge/Atools.thy; - called for each cterm', icalhd, fmz in this interface; - + see "fun decode" in xmlsrc/mathml.sml.*) -fun encode (str:cterm') = - let fun enc [] = [] - | enc ("^"::cs) = "^"::"^"::"^"::(enc cs) - | enc (c::cs) = c::(enc cs) - in (implode o enc o explode) str:cterm' end; -fun encode_imodel (imodel:imodel) = - let fun enc (Given ifos) = Given (map encode ifos) - | enc (Find ifos) = Find (map encode ifos) - | enc (Relate ifos) = Relate (map encode ifos) - in map enc imodel:imodel end; -fun encode_icalhd ((pos', headl, imodel, pos_, spec):icalhd) = - (pos', encode headl, encode_imodel imodel, pos_, spec):icalhd; -fun encode_fmz ((ifos, spec):fmz) = (map encode ifos, spec):fmz; - - -(***. CalcTree .***) - -(** add and delete users **) - -(*.'Iterator 1' must exist with each CalcTree; - the only for updating the calc-tree - WN.0411: only 'Iterator 1' is stored, - all others are just calculated on the fly - TODO: adapt Iterator, add_user(= add_iterator!),etc. accordingly .*) -fun Iterator (cI:calcID) = (*returned ID unnecessary after WN.0411*) - (adduserOK2xml cI (add_user (cI:calcID))) - handle _ => sysERROR2xml cI "error in kernel"; -fun IteratorTEST (cI:calcID) = add_user (cI:calcID); -(*fun DEconstructIterator (cI:calcID) (uI:iterID) = - deluserOK2xml (del_user cI uI);*) - -(*.create a calc-tree; for calls from java: thus ^^^ decoded to ^; - compare "fun CalcTreeTEST" which does NOT decode.*) -fun CalcTree - [(fmz, sp):fmz] (*for several variants lateron*) = -(* val[(fmz,sp):fmz]=[(["fixedValues [r=Arbfix]","maximum A","valuesFor [a,b]", - "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]", - "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]", - "relations [A=a*b, a/2=r*sin alpha, b/2=r*cos alpha]", - "boundVariable a","boundVariable b","boundVariable alpha", - "interval {x::real. 0 <= x & x <= 2*r}", - "interval {x::real. 0 <= x & x <= 2*r}", - "interval {x::real. 0 <= x & x <= pi}", - "errorBound (eps=(0::real))"], - ("DiffApp.thy", ["maximum_of","function"], - ["DiffApp","max_by_calculus"]))]; - - *) - (let val cs = nxt_specify_init_calc (encode_fmz (fmz, sp)) - (*FIXME.WN.8.03: error-handling missing*) - val cI = add_calc cs - in calctreeOK2xml cI end) - handle _ => sysERROR2xml 0 "error in kernel"; - -fun DEconstrCalcTree (cI:calcID) = - deconstructcalctreeOK2xml (del_calc cI); - - -fun getActiveFormula (cI:calcID) = iteratorOK2xml cI (get_pos cI 1); - -fun moveActiveFormula (cI:calcID) (p:pos') = - let val ((pt,_),_) = get_calc cI - in if existpt' p pt then (upd_ipos cI 1 p; iteratorOK2xml cI p) - else sysERROR2xml cI "frontend sends a non-existing pos" end; - -(*. set the next tactic to be applied: dont't change the calc-tree, - but remember the envisaged changes for fun autoCalculate; - compare force NextTactic .*) -(* val (cI, tac) = (1, Add_Given "equality (x ^^^ 2 + 4 * x + 3 = 0)"); - val (cI, tac) = (1, Specify_Theory "PolyEq.thy"); - val (cI, tac) = (1, Specify_Problem ["normalize","polynomial", - "univariate","equation"]); - val (cI, tac) = (1, Subproblem ("Poly.thy", - ["polynomial","univariate","equation"])); - val (cI, tac) = (1, Model_Problem["linear","univariate","equation","test"]); - val (cI, tac) = (1, Detail_Set "Test_simplify"); - val (cI, tac) = (1, Apply_Method ["Test", "solve_linear"]); - val (cI, tac) = (1, Rewrite_Set "Test_simplify"); - *) -fun setNextTactic (cI:calcID) tac = - let val ((pt, _), _) = get_calc cI - val ip = get_pos cI 1 - in case locatetac tac (pt, ip) of -(* val ("ok", (tacis, c, (_,p'))) = locatetac tac (pt, ip); - *) - ("ok", (tacis, _, _)) => - (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "ok") - | ("unsafe-ok", (tacis, _, _)) => - (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "unsafe-ok") - | ("not-applicable",_) => setnexttactic2xml cI "not-applicable" - | ("end-of-calculation",_) => - setnexttactic2xml cI "end-of-calculation" - | ("failure",_) => sysERROR2xml cI "failure" - end; - -(*. apply a tactic at a position and update the calc-tree if applicable .*) -(*WN080226 java-code is missing, errors smltest/IsacKnowledge/polyminus.sml*) -(* val (cI, ip, tac) = (1, p, hd appltacs); - val (cI, ip, tac) = (1, p, (hd (sel_appl_atomic_tacs pt p))); - *) -fun applyTactic (cI:calcID) ip tac = - let val ((pt, _), _) = get_calc cI - val p = get_pos cI 1 - in case locatetac tac (pt, ip) of -(* val ("ok", (tacis, c, (pt',p'))) = locatetac tac (pt, ip); - *) - ("ok", (_, c, ptp as (_,p'))) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p'; - autocalculateOK2xml cI p (if null c then p' - else last_elem c) p') - | ("unsafe-ok", (_, c, ptp as (_,p'))) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p'; - autocalculateOK2xml cI p (if null c then p' - else last_elem c) p') - | ("end-of-calculation", (_, c, ptp as (_,p'))) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p'; - autocalculateOK2xml cI p (if null c then p' - else last_elem c) p') - - - | (str,_) => autocalculateERROR2xml cI "failure" - end; - - - -(* val cI = 1; - *) -fun fetchProposedTactic (cI:calcID) = - (case step (get_pos cI 1) (get_calc cI) of - ("ok", (tacis, _, _)) => - let val _= upd_tacis cI tacis - val (tac,_,_) = last_elem tacis - in fetchproposedtacticOK2xml cI tac end - | ("helpless",_) => fetchproposedtacticERROR2xml cI "helpless" - | ("no-fmz-spec",_) => fetchproposedtacticERROR2xml cI "no-fmz-spec" - | ("end-of-calculation",_) => - fetchproposedtacticERROR2xml cI "end-of-calculation") - handle _ => sysERROR2xml cI "error in kernel"; - -(*datatype auto = FIXXXME040624: does NOT match interfaces/ITOCalc.java - Step of int (*1 do #int steps (may stop in model/specify) - IS VERY INEFFICIENT IN MODEL/SPECIY*) -| CompleteModel (*2 complete modeling - if model complete, finish specifying*) -| CompleteCalcHead (*3 complete model/specify in one go*) -| CompleteToSubpbl (*4 stop at the next begin of a subproblem, - if none, complete the actual (sub)problem*) -| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*) -| CompleteCalc; (*6 complete the calculation as a whole*)*) -fun autoCalculate (cI:calcID) auto = -(* val (cI, auto) = (1,CompleteCalc); - val (cI, auto) = (1,CompleteModel); - val (cI, auto) = (1,CompleteCalcHead); - val (cI, auto) = (1,Step 1); - *) - (let val pold = get_pos cI 1 - val x = autocalc [] pold (get_calc cI) auto - in - case x of -(* val (str, c, ptp as (_,p)) = x; - *) - ("ok", c, ptp as (_,p)) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p; - autocalculateOK2xml cI pold (if null c then pold - else last_elem c) p) - | ("end-of-calculation", c, ptp as (_,p)) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p; - autocalculateOK2xml cI pold (if null c then pold - else last_elem c) p) - | (str, _, _) => autocalculateERROR2xml cI str - end) - handle _ => sysERROR2xml cI "error in kernel"; - - -(* val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = - (1, (([],Pbl), "not used here", - [Given ["fixedValues [r=Arbfix]"], - Find ["maximum A", "valuesFor [a,b]"(*new input*)], - Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl, - ("DiffApp.thy", ["maximum_of","function"], - ["DiffApp","max_by_calculus"]))); - val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = - (1, (([],Pbl),"solve (x+1=2, x)", - [Given ["equality (x+1=2)", "solveFor x"], - Find ["solutions L"]], - Pbl, - ("Test.thy", ["linear","univariate","equation","test"], - ["Test","solve_linear"]))); - val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = - (1, (([],Pbl),"solveTest (1+-1*2+x=0,x)", [], Pbl, ("", [], []))); - val (cI, p:pos')=(1, ([1],Frm)); - val (cI, p:pos')=(1, ([1,2,1,3],Res)); - *) -fun getTactic cI (p:pos') = - (let val ((pt,_),_) = get_calc cI - val (form, tac, asms) = pt_extract (pt, p) - in case tac of -(* val SOME ta = tac; - *) - SOME ta => gettacticOK2xml cI ta - | NONE => gettacticERROR2xml cI ("no tactic at position "^pos'2str p) - end) - handle _ => sysERROR2xml cI "syserror in getTactic"; - -(*. see ICalcIterator#fetchApplicableTactics - @see #TACTICS_ALL - @see #TACTICS_CURRENT_THEORY - @see #TACTICS_CURRENT_METHOD ..the only impl.WN040307.*) -(*. fetch tactics to be applied to a particular step.*) -(* WN071231 kept this version for later parametrisation*) -(*.version 1: fetch _all_ tactics from script .*) -fun fetchApplicableTactics cI (scope:int) (p:pos') = - (let val ((pt, _), _) = get_calc cI - in (applicabletacticsOK cI (sel_rules pt p)) - handle PTREE str => sysERROR2xml cI str - end) - handle _ => sysERROR2xml cI "error in kernel"; -(*.version 2: fetch _applicable_ _elementary_ (ie. recursively - decompose rule-sets) Rewrite*, Calculate .*) -fun fetchApplicableTactics cI (scope:int) (p:pos') = - (let val ((pt, _), _) = get_calc cI - in (applicabletacticsOK cI (sel_appl_atomic_tacs pt p)) - handle PTREE str => sysERROR2xml cI str - end) - handle _ => sysERROR2xml cI "error in kernel"; - -fun getAssumptions cI (p:pos') = - (let val ((pt,_),_) = get_calc cI - val (_, _, asms) = pt_extract (pt, p) - in getasmsOK2xml cI asms end) - handle _ => sysERROR2xml cI "syserror in getAssumptions"; - -(*WN0502 @see ME/ctree: type asms: illdesigned, thus no positions returned*) -fun getAccumulatedAsms cI (p:pos') = - (let val ((pt, _), _) = get_calc cI - val ass = map fst (get_assumptions_ pt p) - in (*getaccuasmsOK2xml cI (get_assumptions_ pt p)*) - getasmsOK2xml cI ass end) - handle _ => sysERROR2xml cI "syserror in getAccumulatedAsms"; - - -(*since moveActive* does NOT transfer pos java --> sml (only sml --> java) - refFormula might become involved in far-off errors !!!*) -fun refFormula cI (p:pos') = (*WN0501 rename to 'fun getElement' !*) -(* val (cI, uI) = (1,1); - *) - (let val ((pt,_),_) = get_calc cI - val (form, tac, asms) = pt_extract (pt, p) - in refformulaOK2xml cI p form end) - handle _ => sysERROR2xml cI "error in kernel"; - -(*.get formulae 'from' 'to' w.r.t. ordering in Position#compareTo(Position p); - in case of CalcHeads only the headline is taken - (the pos' allows distinction between PrfObj and PblObj anyway); - 'level' is adjusted such that an 'interval' of formulae is returned; - 'from' 'to' are designed for use by iterators of calcChangedEvent; - thus 'from' is the last unchanged position.*) -fun getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Pbl):pos')_ false = -(*special case because 'from' is _before_ the first elements to be returned*) -(* val (cI, from, to, level) = (1, ([],Pbl), ([],Pbl), 1); - *) - ((let val ((pt,_),_) = get_calc cI - val (ModSpec (_,_,headline,_,_,_),_,_) = pt_extract (pt, to) - in getintervalOK cI [(to, headline)] end) - handle _ => sysERROR2xml cI "error in kernel") - - | getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Met):pos')_ false = - getFormulaeFromTo cI ([],Pbl) ([],Pbl) (~00000) false - - | getFormulaeFromTo cI (from:pos') (to:pos') level false = -(* val (cI, from, to, level) = (1, unc, gen, 0); - val (cI, from, to, level) = (1, unc, gen, 1); - val (cI, from, to, level) = (1, ([],Pbl), ([],Met), 1); - *) - (if from = to then sysERROR2xml cI "getFormulaeFromTo: From = To" - else - (case from of - ([],Res) => sysERROR2xml cI "getFormulaeFromTo does: moveDown \ - \from=([],Res) .. goes beyond result" - | _ => let val ((pt,_),_) = get_calc cI - val f = move_dn [] pt from - fun max (a,b) = if a < b then b else a - (*must reach margins ...*) - val lev = max (level, max (lev_of from, lev_of to)) - in getintervalOK cI (get_interval f to lev pt) end) - handle _ => sysERROR2xml cI "error in getFormulaeFromTo") - - | getFormulaeFromTo cI from to level true = - sysERROR2xml cI "getFormulaeFromTo impl.for formulae only,\ - \i.e. last arg only impl. for false, _NOT_ true"; - - -(* val (cI, ip) = (1, ([1,9], Res)); - val (cI, ip) = (1, ([], Res)); - val (cI, ip) = (1, ([2], Res)); - val (cI, ip) = (1, ([3,1], Res)); - val (cI, ip) = (1, ([1,2,1], Res)); - *) -fun interSteps cI ip = - (let val ((pt,p), tacis) = get_calc cI - in if (not o is_interpos) ip - then interStepsERROR cI "only formulae with position (_,Res) \ - \may have intermediate steps above them" - else let val ip' = lev_pred' pt ip -(* val (str, pt', lastpos) = detailstep pt ip; - *) - in case detailstep pt ip of - ("detailrls", pt(*, pos'forms*), lastpos) => - (upd_calc cI ((pt, p), tacis); - interStepsOK cI (*pos'forms*) ip' ip' lastpos) - | ("no-Rewrite_Set...", _, _) => - sysERROR2xml cI "no Rewrite_Set..." - | (_, _(*, pos'formshds*), lastpos) => - interStepsOK cI (*pos'formshds*) ip' ip' lastpos - end - end) - handle _ => sysERROR2xml cI "error in kernel"; - -fun modifyCalcHead (cI:calcID) (ichd as ((p,_),_,_,_,_):icalhd) = - (let val ((pt,_),_) = get_calc cI - val (pt, chd as (_,p_,_,_,_,_)) = input_icalhd pt ichd - in (upd_calc cI ((pt, (p,p_)), []); - modifycalcheadOK2xml cI chd) end) - handle _ => sysERROR2xml cI "error in kernel"; - -(*.at the activeFormula set the Model, the Guard and the Specification - to empty and return a CalcHead; - the 'origin' remains (for reconstructing all that).*) -fun resetCalcHead (cI:calcID) = - (let val (ptp,_) = get_calc cI - val ptp = reset_calchead ptp - in (upd_calc cI (ptp, []); - modifycalcheadOK2xml cI (get_ocalhd ptp)) end) - handle _ => sysERROR2xml cI "error in kernel"; - -(*.at the activeFormula insert all the Descriptions in the Model - (_not_ in the Guard) and return a CalcHead; - the Descriptions are for user-guidance; the rest of the items - are left empty for user-input; - includes a resetCalcHead for the Model and the Guard.*) -fun modelProblem (cI:calcID) = - (let val (ptp, _) = get_calc cI - val ptp = reset_calchead ptp - val (_, _, ptp) = nxt_specif Model_Problem ptp - in (upd_calc cI (ptp, []); - modifycalcheadOK2xml cI (get_ocalhd ptp)) end) - handle _ => sysERROR2xml cI "error in kernel"; - - -(*.set the context determined on a knowledgebrowser to the current calc.*) -fun setContext (cI:calcID) (ip as (_,p_):pos') (guh:guh) = - (case (implode o (take_fromto 1 4) o explode) guh of - "thy_" => -(* val (cI, ip as (_,p_), guh) = (1, p, "thy_isac_Test-rls-Test_simplify"); - *) - if member op = [Pbl,Met] p_ - then message2xml cI "thy-context not to calchead" - else if ip = ([],Res) then message2xml cI "no thy-context at result" - else if no_thycontext guh then message2xml cI ("no thy-context for '"^ - guh ^ "'") - else let val (ptp as (pt,pold),_) = get_calc cI - val is = get_istate pt ip - val subs = subs_from is "dummy" guh - val tac = guh2rewtac guh subs - in case locatetac tac (pt, ip) of (*='fun setNextTactic'+step*) - ("ok", (tacis, c, ptp as (_,p))) => -(* val (str, (tacis, c, ptp as (_,p))) = locatetac tac (pt, ip); - *) - (upd_calc cI ((pt,p), []); - autocalculateOK2xml cI pold (if null c then pold - else last_elem c) p) - | ("unsafe-ok", (tacis, c, ptp as (_,p))) => - (upd_calc cI ((pt,p), []); - autocalculateOK2xml cI pold (if null c then pold - else last_elem c) p) - | ("end-of-calculation",_) => - message2xml cI "end-of-calculation" - | ("failure",_) => sysERROR2xml cI "failure" - | ("not-applicable",_) => (*the rule comes from anywhere..*) - (case applicable_in ip pt tac of - - Notappl e => message2xml cI ("'" ^ tac2str tac ^ - "' not-applicable") - | Appl m => - let val (p,c,_,pt) = generate1 (assoc_thy"Isac.thy") - m Uistate ip pt - in upd_calc cI ((pt,p),[]); - autocalculateOK2xml cI pold (if null c then pold - else last_elem c) p - end) - end -(* val (cI, ip as (_,p_), guh) = (1, pos, guh); - *) - | "pbl_" => - let val pI = guh2kestoreID guh - val ((pt, _), _) = get_calc cI - (*val ip as (_, p_) = get_pos cI 1*) - in if member op = [Pbl, Met] p_ - then let val (pt, chd) = set_problem pI (pt, ip) - in (upd_calc cI ((pt, ip), []); - modifycalcheadOK2xml cI chd) end - else sysERROR2xml cI "setContext for pbl requires ActiveFormula \ - \on CalcHead" - end -(* val (cI, ip as (_,p_), guh) = (1, pos, "met_eq_lin"); - *) - | "met_" => - let val mI = guh2kestoreID guh - val ((pt, _), _) = get_calc cI - in if member op = [Pbl, Met] p_ - then let val (pt, chd) = set_method mI (pt, ip) - in (upd_calc cI ((pt, ip), []); - modifycalcheadOK2xml cI chd) end - else sysERROR2xml cI "setContext for met requires ActiveFormula \ - \on CalcHead" - end) - handle _ => sysERROR2xml cI "error in kernel"; - - -(*.specify the Method at the activeFormula and return a CalcHead - containing the Guard. - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*) -fun setMethod (cI:calcID) (mI:metID) = -(* val (cI, mI) = (1, ["Test","solve_linear"]); - *) - (let val ((pt, _), _) = get_calc cI - val ip as (_, p_) = get_pos cI 1 - in if member op = [Pbl,Met] p_ - then let val (pt, chd) = set_method mI (pt, ip) - in (upd_calc cI ((pt, ip), []); - modifycalcheadOK2xml cI chd) end - else sysERROR2xml cI "setMethod requires ActiveFormula on CalcHead" - end) - handle _ => sysERROR2xml cI "error in kernel"; - -(*.specify the Problem at the activeFormula and return a CalcHead - containing the Model; special case of checkContext; - WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem '.*) -fun setProblem (cI:calcID) (pI:pblID) = - (let val ((pt, _), _) = get_calc cI - val ip as (_, p_) = get_pos cI 1 - in if member op = [Pbl,Met] p_ - then let val (pt, chd) = set_problem pI (pt, ip) - in (upd_calc cI ((pt, ip), []); - modifycalcheadOK2xml cI chd) end - else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead" - end) - handle _ => sysERROR2xml cI "error in kernel"; - -(*.specify the Theory at the activeFormula and return a CalcHead; - special case of checkContext; - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*) -fun setTheory (cI:calcID) (tI:thyID) = - (let val ((pt, _), _) = get_calc cI - val ip as (_, p_) = get_pos cI 1 - in if member op = [Pbl,Met] p_ - then let val (pt, chd) = set_theory tI (pt, ip) - in (upd_calc cI ((pt, ip), []); - modifycalcheadOK2xml cI chd) end - else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead" - end) - handle _ => sysERROR2xml cI "error in kernel"; - - -(**. without update of CalcTree .**) - -(*.match the model of a problem at pos p - with the model-pattern of the problem with pblID*) -(*fun tryMatchProblem cI pblID = - (let val ((pt,_),_) = get_calc cI - val p = get_pos cI 1 - val chd = trymatch pblID pt p - in trymatchOK2xml cI chd end) - handle _ => sysERROR2xml cI "error in kernel";*) - -(*.refinement for the parent-problem of the position.*) -(* val (cI, (p,p_), guh) = (1, ([1],Res), "pbl_equ_univ"); - *) -fun refineProblem cI ((p,p_) : pos') (guh : guh) = - (let val pblID = guh2kestoreID guh - val ((pt,_),_) = get_calc cI - val pp = par_pblobj pt p - val chd = tryrefine pblID pt (pp, p_) - in matchpbl2xml cI chd end) - handle _ => sysERROR2xml cI "error in kernel"; - -(* val (cI, ifo) = (1, "-2 * 1 + (1 + x) = 0"); - val (cI, ifo) = (1, "x = 2"); - val (cI, ifo) = (1, "[x = 3 + -2*1]"); - val (cI, ifo) = (1, "-1 + x = 0"); - val (cI, ifo) = (1, "x - 4711 = 0"); - val (cI, ifo) = (1, "2+ -1 + x = 2"); - val (cI, ifo) = (1, " x - "); - val (cI, ifo) = (1, "(-3 * x + 4 * y + -1 * x * y) / (x * y)"); - val (cI, ifo) = (1, "(4 * y + -3 * x) / (x * y) + -1"); - *) -fun appendFormula cI (ifo:cterm') = - (let val cs = get_calc cI - val pos as (_,p_) = get_pos cI 1 - in case step pos cs of -(* val (str, cs') = step pos cs; - *) - ("ok", cs') => - (case inform cs' (encode ifo) of -(* val (str, (_, c, ptp as (_,p))) = inform cs' (encode ifo); - *) - ("ok", (_(*use in DG !!!*), c, ptp as (_,p))) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p; - appendformulaOK2xml cI pos (if null c then pos - else last_elem c) p) - | ("same-formula", (_, c, ptp as (_,p))) => - (upd_calc cI (ptp, []); upd_ipos cI 1 p; - appendformulaOK2xml cI pos (if null c then pos - else last_elem c) p) - | (msg, _) => appendformulaERROR2xml cI msg) - | (msg, cs') => appendformulaERROR2xml cI msg - end) - handle _ => sysERROR2xml cI "error in kernel"; - - - -(*.replace a formula with_in_ a calculation; - this situation applies for initial CAS-commands, too.*) -(* val (cI, ifo) = (2, "-1 + x = 0"); - val (cI, ifo) = (1, "-1 + x = 0"); - val (cI, ifo) = (1, "x - 1 = 0"); - val (cI, ifo) = (1, "x = 1"); - val (cI, ifo) = (1, "solve(x+1=2,x)"); - val (cI, ifo) = (1, "Simplify (2*a + 3*a)"); - val (cI, ifo) = (1, "Diff (x^2 + x + 1, x)"); - *) -fun replaceFormula cI (ifo:cterm') = - (let val ((pt, _), _) = get_calc cI - val p = get_pos cI 1 - in case inform (([], [], (pt, p)): calcstate') (encode ifo) of - ("ok", (_(*tacs used for DG ?*), c, ptp' as (pt',p'))) => -(* val (str, (_,c, ptp' as (pt',p')))= inform ([], [], (pt, p)) (encode ifo); - *) - let val unc = if null (fst p) then p else move_up [] pt p - val _ = upd_calc cI (ptp', []) - val _ = upd_ipos cI 1 p' - in replaceformulaOK2xml cI unc - (if null c then unc - else last_elem c) p'(*' NEW*) end - | ("same-formula", _) => - (*TODO.WN0501 MESSAGE !*) - replaceformulaERROR2xml cI "formula not changed" - | (msg, _) => replaceformulaERROR2xml cI msg - end) - handle _ => sysERROR2xml cI "error in kernel"; - - - -(***. CalcIterator - moveActive*: set the pos' of the active formula stored with the calctree - could take pos' as argument for consistency checks - move*: compute the new iterator from the old one on the fly - -.***) - -fun moveActiveRoot cI = - (let val _ = upd_ipos cI 1 ([],Pbl) - in iteratorOK2xml cI ([],Pbl) end) - handle e => sysERROR2xml cI "error in kernel"; -fun moveRoot cI = - (iteratorOK2xml cI ([],Pbl)) - handle e => sysERROR2xml cI ""; -fun moveActiveRootTEST cI = - (let val _ = upd_ipos cI 1 ([],Pbl) - in (*iteratorOK2xml cI ([],Pbl)*)() end) - handle e => sysERROR2xml cI "error in kernel"; - -(* val (cI, uI) = (1,1); - val (cI, uI) = (1,2); - *) -fun moveActiveDown cI = - ((let val ((pt,_),_) = get_calc cI -(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI); - val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI); - - print_depth 7;pt - *) - val ip' = move_dn [] pt (get_pos cI 1) - val _ = upd_ipos cI 1 ip' - in iteratorOK2xml cI ip' end) - handle (PTREE e) => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveDown cI (p:pos') = - ((let val ((pt,_),_) = get_calc cI -(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI); - val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI); - - print_depth 7;pt - *) - val ip' = move_dn [] pt p - in iteratorOK2xml cI ip' end) - handle (PTREE e) => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveActiveDownTEST cI = - let val ((pt,_),_) = get_calc cI - val ip = get_pos cI 1 - val ip' = (move_dn [] pt ip) - handle _ => ip - val _ = upd_ipos cI 1 ip' - in (*iteratorOK2xml cI uI*)() end; - -fun moveActiveLevelDown cI = - ((let val ((pt,_),_) = get_calc cI - val ip' = movelevel_dn [] pt (get_pos cI 1) - val _ = upd_ipos cI 1 ip' - in iteratorOK2xml cI ip' end) - handle (PTREE e) => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveLevelDown cI (p:pos') = - ((let val ((pt,_),_) = get_calc cI - val ip' = movelevel_dn [] pt p - in iteratorOK2xml cI ip' end) - handle (PTREE e) => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; - -fun moveActiveUp cI = - ((let val ((pt,_),_) = get_calc cI - val ip' = move_up [] pt (get_pos cI 1) - val _ = upd_ipos cI 1 ip' - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveUp cI (p:pos') = - ((let val ((pt,_),_) = get_calc cI - val ip' = move_up [] pt p - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; - -fun moveActiveLevelUp cI = - ((let val ((pt,_),_) = get_calc cI - val ip' = movelevel_up [] pt (get_pos cI 1) - val _ = upd_ipos cI 1 ip' - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveLevelUp cI (p:pos') = - ((let val ((pt,_),_) = get_calc cI - val ip' = movelevel_up [] pt p - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; - -fun moveActiveCalcHead cI = - ((let val ((pt,_),_) = get_calc cI - val ip' = movecalchd_up pt (get_pos cI 1) - val _ = upd_ipos cI 1 ip' - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; -fun moveCalcHead cI (p:pos') = - ((let val ((pt,_),_) = get_calc cI - val ip' = movecalchd_up pt p - in iteratorOK2xml cI ip' end) - handle PTREE e => iteratorERROR2xml cI) - handle _ => sysERROR2xml cI "error in kernel"; - - -(*.initContext Thy_ is conceptually impossible at [Pbl,Met] - and at positions with Check_Postcond and End_Trans; - at possible pos's there can be NO rewrite (returned as a context, too).*) -(* val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1], Frm)); - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([], Res)); - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([2], Res)); - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1,1], Frm)); - *) -fun initContext (cI:calcID) Thy_ (pos as (p,p_):pos') = - ((if member op = [Pbl,Met] p_ - then message2xml cI "thy-context not to calchead" - else if pos = ([],Res) then message2xml cI "no thy-context at result" - else let val cs as (ptp as (pt,_),_) = get_calc cI - in if exist_lev_on' pt pos - then let val pos' = lev_on' pt pos - val tac = get_tac_checked pt pos' - in if is_rewtac tac - then contextthyOK2xml cI (context_thy (pt,pos) tac) - else message2xml cI ("no thy-context at tac '" ^ - tac2str tac ^ "'") - end - else if is_curr_endof_calc pt pos - then case step pos cs of -(* val (str, (tacis, _, (pt,_))) = step pos cs; - val ("ok", (tacis, _, (pt,_))) = step pos cs; - *) - ("ok", (tacis, _, (pt,_))) => - let val tac = fst3 (last_elem tacis) - in if is_rewtac tac - then contextthyOK2xml - cI (context_thy ptp tac) - else message2xml cI ("no thy-context at tac '" ^ - tac2str tac ^ "'") - end - | (msg, _) => message2xml cI msg - else message2xml cI "no thy-context at this position" - end) - handle _ => sysERROR2xml cI "error in kernel") - -(* val (cI, Pbl_, pos as (p,p_)) = (1, Pbl_, ([],Pbl)); - *) - | initContext cI Pbl_ (pos as (p,p_):pos') = - ((let val ((pt,_),_) = get_calc cI - val pp = par_pblobj pt p - val chd = initcontext_pbl pt (pp,p_) - in matchpbl2xml cI chd end) - handle _ => sysERROR2xml cI "error in kernel") - - | initContext cI Met_ (pos as (p,p_):pos') = - ((let val ((pt,_),_) = get_calc cI - val pp = par_pblobj pt p - val chd = initcontext_met pt (pp,p_) - in matchmet2xml cI chd end) - handle _ => sysERROR2xml cI "error in kernel"); - - - -(*.match a theorem, a ruleset (etc., selected in the knowledge-browser) -with the formula in the focus on the worksheet; -string contains the thy, thus it is unique as thmID, rlsID for this thy; -take the substitution from the istate of the formula.*) -(* use"../smltest/IsacKnowledge/poly.sml"; - val (cI, pos as (p,p_), guh) = (1, ([1,1,1], Frm), - "thy_Poly-thm-real_diff_minus"); - val (cI, pos as (p,p_), guh) = (1, ([1,1], Frm), "norm_Poly"); - val (cI, pos as (p,p_), guh) = - (1, ([1], Res), "thy_isac_Test-rls-Test_simplify"); - *) -fun checkContext (cI:calcID) (pos:pos' as (p,p_)) (guh:guh) = - (case (implode o (take_fromto 1 4) o explode) guh of - "thy_" => - if member op = [Pbl,Met] p_ - then message2xml cI "thy-context not to calchead" - else if pos = ([],Res) then message2xml cI "no thy-context at result" - else if no_thycontext guh then message2xml cI ("no thy-context for '"^ - guh ^ "'") - else let val (ptp as (pt,_),_) = get_calc cI - val is = get_istate pt pos - val subs = subs_from is "dummy" guh - val tac = guh2rewtac guh subs - in contextthyOK2xml cI (context_thy (pt, pos) tac) end - - (*.match the model of a problem at pos p - with the model-pattern of the problem with pblID.*) -(* val (cI, pos:pos' as (p,p_), guh) = - (1, p, kestoreID2guh Pbl_ ["univariate","equation"]); - val (cI, pos:pos' as (p,p_), guh) = - (1, ([],Pbl), kestoreID2guh Pbl_ ["univariate","equation"]); - val (cI, pos:pos' as (p,p_), guh) = - (1, ([],Pbl), "pbl_equ_univ"); - *) - | "pbl_" => - let val ((pt,_),_) = get_calc cI - val pp = par_pblobj pt p - val keID = guh2kestoreID guh - val chd = context_pbl keID pt pp - in matchpbl2xml cI chd end -(* val (cI, pos:pos' as (p,p_), guh) = - (1, ([],Pbl), kestoreID2guh Met_ ["LinEq", "solve_lineq_equation"]); - *) - | "met_" => - let val ((pt,_),_) = get_calc cI - val pp = par_pblobj pt p - val keID = guh2kestoreID guh - val chd = context_met keID pt pp - in matchmet2xml cI chd end) - handle _ => sysERROR2xml cI "error in kernel"; - - -(*------------------------------------------------------------------*) -end -open interface; -(*------------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/FE-interface/messages.sml --- a/src/Tools/isac/FE-interface/messages.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -(* all messages are encoded to integers for the multi-language system - use"FE-interface/messages.sml"; - use"messages.sml"; - *) - -datatype language = English | German | Japanese; -fun language2str English = "English" - | language2str German = "German" - | language2str Japanese = "Japanese"; - -val language = English; - -(*1000 system*) -fun msg2str 1000 English = - "msg 1000 English" - | msg2str 1000 German = - "msg 1000 German" - -(*2000 user in model- and specify-phase*) - | msg2str 2020 English = - "Kernel cannot propose a tactic (helpless!)" - - -(*3000 user in solve-phase*) - -(*4000 general*) - -(*5000 general*) - -(*6000 general*) - -(*7000 general*) - -(*1000 general*) - -(*1000 general*) - -(*1000 general*) - -(*1000 general*) - - | msg2str i l = raise error ("no message for No. "^ - string_of_int i^" "^language2str l); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/FE-interface/states.sml --- a/src/Tools/isac/FE-interface/states.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,487 +0,0 @@ -(* states for calculation in global refs - use"../states.sml"; - use"states.sml"; - *) - -(* -type hide = (pblID * - string list * (*hide: tacs + - "ALL", .. result immediately - "MODELPBL", .. modeling hidden - "SPEC", .. specifying hidden - "MODELMET", .. (additional itms !) - "APPLY", .. solving hidden - detail: rls - "Rewrite_*" (as strings) must _not_ be .. - .. contained in this list, rls _only_ !*) - bool) (*inherit to children in pbl-herarchy*) - list; - -(*. points a pbl/metID to a sub-hierarchy of key ?.*) -fun is_child_of child key = - let fun is_ch [] [] = true (*is child of itself*) - | is_ch (c::_) [] = true - | is_ch [] (k::_) = false - | is_ch (c::cs) (k::ks) = - if c = k then is_ch cs ks else false - in is_ch (rev child) (rev key) end; -(* -is_child_of ["root","univar","equation"] ["univar","equation"]; -val it = true : bool -is_child_of ["root","univar","equation"] ["system","equation"]; -val it = false : bool -is_child_of ["equation"] ["system","equation"]; -val it = false : bool -is_child_of ["root","univar","equation"] ["linear","univar","equation"]; -val it = false : bool -*) - -(*.what tactics have to be hidden (in model/specify these may be several).*) -datatype hid = - Show (**) - | Hundef (**) - | Htac (*a tactic has to be hidden*) - | Hmodel (*the model of the (sub)problem has to be hidden*) - | Hspecify (*the specification of the (sub)problem has to be hidden*) - | Happly; (*solving the (sub)problem has to be hidden*) - -(*. search all pbls if there is some tactic or model/spec/calc to hide .*) -fun is_hid pblID arg [] = Show - | is_hid pblID arg ((pblID', strs, inherit)::pts) = - let fun is_mem arg = - if arg mem strs then Htac - else if arg mem ["Add_Given","Add_Find","Add_Relation"] - andalso "MODEL" mem strs then Hmodel - else if arg mem ["Specify_Theory","Specify_Problem", - "Specify_Method"] - andalso "SPEC" mem strs then Hspecify - else if "APPLY" mem strs then Htac - else Hundef - in if inherit then - if is_child_of (pblID:pblID) pblID' - then case is_mem arg of Hundef => is_hid pblID arg (pts:hide) - | hid => hid - else is_hid pblID arg pts - else if pblID = pblID' - then case is_mem arg of Hundef => is_hid pblID arg (pts:hide) - | hid => hid - else is_hid pblID arg pts - end; -(*val hide = [([],["Refine_Tacitly"],true), - (["univar","equation"],["Apply_Method","Model_Problem","SPEC"], - false)] - :hide; -is_hid [] "Rewrite" hide; -val it = Show -is_hid ["any","problem"] "Refine_Tacitly" hide; -val it = Htac -is_hid ["root","univar","equation"] "Apply_Method" hide; -val it = Show -is_hid ["univar","equation"] "Apply_Method" hide; -val it = Htac -is_hid ["univar","equation"] "Specify_Problem" hide; -val it = Hspecify -*) - -fun is_hide pblID (tac as (Subproblem (_,pI))) (det:detail) = - is_hid pblID "SELF" det - | is_hide pblID (tac as (Rewrite (thmID,_))) det = - is_hid pblID thmID det - | is_hide pblID (tac as (Rewrite_Inst (_,(thmID,_)))) det = - is_hid pblID thmID det - | is_hide pblID (tac as (Rewrite_Set rls)) det = - is_hid pblID rls det - | is_hide pblID (tac as (Rewrite_Set_Inst (_,rls))) det = - is_hid pblID rls det - | is_hide pblID tac det = is_hid pblID (tac2IDstr tac) det; -(*val hide = [([],["Refine_Tacitly"],true), - (["univar","equation"],["Apply_Method","Model_Problem", - "SPEC","SELF"], - false)] - :hide; -is_hide [] (Rewrite ("","")) hide; -val it = Show -is_hide ["any","problem"] (Refine_Tacitly []) hide; -val it = Htac -is_hide ["root","univar","equation"] (Apply_Method []) hide; -val it = Show -is_hide ["univar","equation"] (Apply_Method []) hide; -val it = Htac -is_hide ["univar","equation"] (Specify_Problem []) hide; -val it = Hspecify -is_hide ["univar","equation"] (Subproblem (e_domID,["univar","equation"]))hide; -val it = Htac -is_hide ["equation"] (Subproblem (e_domID,["univar","equation"]))hide; -val it = Show -*) - - -(*. search all pbls in detail if there is some rls' to be detailed .*) -fun is_det pblID arg [] = false - | is_det pblID arg ((pblID', rlss, inherit)::pts) = - if inherit then - if is_child_of (pblID:pblID) pblID' - then if arg mem rlss then true - else is_det pblID arg (pts:detail) - else is_det pblID arg pts - else if pblID = pblID' - then if arg mem rlss then true - else is_det pblID arg (pts:detail) - else is_det pblID arg pts; - -(*fun is_detail pblID (tac as (Subproblem (_,pI))) (det:detail) = - is_det pblID "SELF" det*) -fun is_detail pblID (tac as (Rewrite_Set rls)) det = - is_det pblID rls det - | is_detail pblID (tac as (Rewrite_Set_Inst (_,rls))) det = - is_det pblID rls det - | is_detail _ _ _ = false; -----------------------------------------*) - -type iterID = int; -type calcID = int; - -(*FIXME.WN.9.03: ev. resdesign calcstate + pos for CalcIterator -type state = - (*pos' * set by the CalcIterator ---> for each user*) - calcstate; (*to which ev.included 'preview' tac_s could be applied*) -val e_state = (e_pos', e_calcstate):state; -val states = ref ([]:(iterID * (calcID * state) list) list); -*) - -val states = - ref ([]:(calcID * - (calcstate * - (iterID * (*1 sets the 'active formula'*) - pos' (*for iterator of a user *) - ) list)) list); -(* -states:= [(3,(e_calcstate, [(1,e_pos'), - (3,e_pos')])), - (4,(e_calcstate, [(1,e_pos'), - (2,e_pos')]))]; -*) - -(** create new instances of users and ptrees - new keys are the lowest possible in the association list **) - -(* add users *) -fun new_key u n = case assoc (u, n) of - NONE => n -| SOME _ => new_key u (n+1); -(*///10.10 -fun get_calcID (u:(calcID * (calcstate * (iterID * pos') list)) list) = - (new_key u 1):calcID;*) -(* -val new_iterID = get_calcID (!states); -val it = 1 : int -states:= (!states) @ [(new_iterID, [])]; -!states; -val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[])] -*) - -(*///7.10.03/// add states to a users active states -fun get_calcID (uI:iterID) (p:(iterID * (calcID * state) list) list) = - case assoc (p, uI) of - NONE => raise error ("get_calcID: no iterID " ^ - (string_of_int uI)) - | SOME ps => (new_key ps 1):calcID; -> get_calcID 1 (!states); -val it = 1 : calcID -*) -(* add users to a calcstate *) -fun get_iterID (cI:calcID) - (p:(calcID * (calcstate * (iterID * pos') list)) list) = - case assoc (p, cI) of - NONE => raise error ("get_iterID: no iterID " ^ (string_of_int cI)) - | SOME (_, us) => (new_key us 1):iterID; -(* get_iterID 3 (!states); -val it = 2 : iterID*) - - -(** retrieve, update, delete a state by iterID, calcID **) - -(*//////7.10. -fun get_cal (uI:iterID) (pI:calcID) (p:(iterID * (calcID * state) list) list) = - (the (assoc2 (p,(uI, pI)))) - handle _ => raise error ("get_state " ^ (string_of_int uI) ^ - " " ^ (string_of_int pI) ^ " not existent"); -> get_cal 3 1 (!states); -val it = (((EmptyPtree,(#,#)),[]),([],[])) : state -*) - -(*///7.10. -fun get_state (uI:iterID) (pI:calcID) = get_cal uI pI (!states); -fun get_calc (uI:iterID) (pI:calcID) = (snd o (get_cal uI pI)) (!states); -*) -fun get_calc (cI:calcID) = - case assoc (!states, cI) of - NONE => raise error ("get_calc "^(string_of_int cI)^" not existent") - | SOME (c, _) => c; -fun get_pos (cI:calcID) (uI:iterID) = - case assoc (!states, cI) of - NONE => raise error ("get_pos: calc " ^ (string_of_int cI) - ^ " not existent") - | SOME (_, us) => - (case assoc (us, uI) of - NONE => raise error ("get_pos: user " ^ (string_of_int uI) - ^ " not existent") - | SOME p => p); - - -fun del_assoc ([],_) = [] - | del_assoc a = - let fun del ([], key) ps = ps - | del ((keyi, xi) :: pairs, key) ps = - if key = keyi then ps @ pairs - else del (pairs, key) (ps @ [(keyi, xi)]) - in del a [] end; -(* -> val ps = [(1,"1"),(2,"2"),(3,"3"),(4,"4")]; -> del_assoc (ps,3); -val it = [(1,"1"),(2,"2"),(4,"4")] : (int * string) list -*) - -(* delete doesn't report non existing elements *) -(*/////7.10. -fun del_assoc2 (uI:iterID) (pI:calcID) ps = - let val new_ps = del_assoc (the (assoc (ps, uI)), pI) - in overwrite (ps, (uI, new_ps)) end;*) -(* -> states:= del_assoc2 4 41 (!states); -> !states; -val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#)]),(1,[(#,#)])] : states - -> del_user 3; -> !states; -val it = [(4,[(#,#)]),(1,[(#,#)])] : states -*) -fun del_assoc2 (cI:calcID) (uI:iterID) ps = - case assoc (ps, cI) of - NONE => ps - | SOME (cs, us) => - overwrite (ps, (cI, (cs, del_assoc (us, uI)))); -(* -> del_assoc2 4 1 (!states); -val it = - [(3, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (3, ([], Und))])), - (4, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]*) - -(*///7.10. -fun overwrite2 (ps, (((uI:iterID), (pI:calcID)), p)) = - let val new_ps = overwrite (the (assoc (ps, uI)), (pI, p)) - in (overwrite (ps, (uI, new_ps))) - handle _ => raise error ("overwrite2 " ^ (string_of_int uI) ^ - " " ^ (string_of_int pI) ^ " not existent") - end;*) -fun overwrite2 (ps, (((cI:calcID), (uI:iterID)), p)) = - case assoc (ps, cI) of - NONE => - raise error ("overwrite2: calc " ^ (string_of_int uI) ^" not existent") - | SOME (cs, us) => - overwrite (ps, (cI ,(cs, overwrite (us, (uI, p))))); - -fun upd_calc (cI:calcID) cs = - case assoc (!states, cI) of - NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent") - | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us))); -(*WN051210 testing before initac: only 1 taci in calcstate so far: -fun upd_calc (cI:calcID) (cs as (_, tacis):calcstate) = - (if length tacis > 1 - then raise error ("upd_calc, |tacis|>1: "^tacis2str tacis) - else (); - case assoc (!states, cI) of - NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent") - | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us))) - );*) - - -(*///7.10. -fun upd_tacis (uI:iterID) (pI:calcID) tacis = - let val (p, (ptp,_)) = get_state uI pI - in states:= - overwrite2 ((!states), ((uI, pI), (p, (ptp, tacis)))) end;*) -fun upd_tacis (cI:calcID) tacis = - case assoc (!states, cI) of - NONE => - raise error ("upd_tacis: calctree "^(string_of_int cI)^" not existent") - | SOME ((ptp,_), us) => - states:= overwrite (!states, (cI, ((ptp, tacis), us))); -(*///7.10. -fun upd_ipos (uI:iterID) (pI:calcID) (ip:pos') = - let val (_, calc) = get_state uI pI - in states:= overwrite2 ((!states), ((uI, pI), (ip, calc))) end;*) -fun upd_ipos (cI:calcID) (uI:iterID) (ip:pos') = - case assoc (!states, cI) of - NONE => - raise error ("upd_ipos: calctree "^(string_of_int cI)^" not existent") - | SOME (cs, us) => - states:= overwrite2 (!states, ((cI, uI), ip)); - - -(** add and delete calcs **) - -(*///7.10 -fun add_pID (uI:iterID) (s:state) (p:(iterID * (calcID * state) list) list) = - let val new_ID = get_calcID uI p; - val new_states = (the (assoc (p, uI))) @ [(new_ID, s)]; - in (new_ID, (overwrite (p, (uI, new_states)))) end;*) -(* -> val (new_calcID, new_states) = add_pID 1 (!states); -> states:= new_states; -> !states; -val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states -> val (new_calcID, new_states) = add_pID 3 (!states); -> states:= new_states; -> !states; -val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states -> assoc2 (!states, (3, 1)); -val it = SOME EmptyPtree : ptree option -> assoc2 (!states, (3, 2)); -val it = NONE : ptree option -*) -(*///7.10 -fun add_calc (uI:iterID) (s:state) = - let val (new_calcID, new_calcs) = add_pID uI s (!states) - in states:= new_calcs; - new_calcID end; *) -fun add_user (cI:calcID) = - case assoc (!states, cI) of - NONE => - raise error ("add_user: calctree "^(string_of_int cI)^" not existent") - | SOME (cs, us) => - let val new_uI = new_key us 1 - in states:= overwrite2 (!states, ((cI, new_uI), e_pos')); - new_uI:iterID end; - -(*///10.10. -fun del_calc (uI:iterID) (pI:calcID) = - (states:= del_assoc2 uI pI (!states); pI);*) -fun del_user (cI:calcID) (uI:iterID) = - (states:= del_assoc2 cI uI (!states); uI); - - -(** add and delete calculations **) -(**///7.10 add and delete users **) -(*///7.10 -fun add_user () = - let val new_uI = get_calcID (!states) - in states:= (!states) @ [(new_uI, [])]; - new_uI end;*) -fun add_calc (cs:calcstate) = - let val new_cI = new_key (!states) 1 - in states:= (!states) @ [(new_cI, (cs, []))]; - new_cI:calcID end; - -(* delete doesn't report non existing elements *) -(*///7.10 -fun del_user (uI:userID) = - (states:= del_assoc (!states, uI); uI);*) -fun del_calc (cI:calcID) = - (states:= del_assoc (!states, cI); cI:calcID); - -(* -------------- test all exported funs -------------- -///7.10 -Compiler.Control.Print.printDepth:=8; -states:=[]; -add_user (); add_user (); !states; -ML> val it = 1 : userID -ML> val it = 2 : userID -ML> val it = [(1,[]),(2,[])] - -val (hide,detail) = ([(["pI"],["tac"],true)]:hide, - [(["pI"],["tac"],true)]:detail); -add_calc 1 e_state; -add_calc 1 (e_calcstate,(hide,detail)); !states; -ML> val it = 1 : calcID -ML> val it = 2 : calcID -ML> val it = - [(1, - [(1,(((EmptyPtree,(#,#)),[]),([],[]))), - (2,(((EmptyPtree,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])] - -val (pt,(p,p_)) = (EmptyPtree,e_pos'); -val (pt,_) = cappend_problem pt p Uistate ([],e_spec); -upd_calc 1 2 ((pt,(p,p_)),[]); !states; -ML> val it = - [(1, - [(1,(((EmptyPtree,(#,#)),[]),([],[]))), - (2,(((Nd #,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])] -(* ~~~~~~~~~~~~~~~~~~~~ unchanged !!!*) - -get_state 1 1; get_state 1 2; -ML> val it = (((EmptyPtree,([],Und)),[]),([],[])) : state -ML> val it = - (((Nd - (PblObj - {branch=NoBranch,cell=[],env=(#,#,#,#),loc=(#,#),meth=[], - model={Find=#,Given=#,Relate=#,Where=#,With=#},origin=(#,#), - ostate=Incomplete,probl=[],result=(#,#),spec=(#,#,#)},[]),([],Und)), - []),([(["pI"],["tac"],true)],[(["pI"],["tac"],true)])) : state - -del_calc 2 1 (*non existent - NO msg!*); del_calc 1 2; !states; -ML> val it = [(1,[(1,(((EmptyPtree,(#,#)),[]),([],[])))]),(2,[])] - -del_user 1; !states; -ML> val it = [(2,[])] - -add_user (); add_user (); !states; -ML> val it = 1 : userID -ML> val it = 3 : userID -ML> val it = [(2,[]),(1,[]),(3,[])] -*) - - -(* -------------- test all exported funs -------------- -print_depth 9; -states:=[]; -add_calc e_calcstate; add_calc e_calcstate; !states; -|val it = 1 : calcID -|val it = 2 : calcID -|val it = -| [(1, (((EmptyPtree, ([], Und)), []), [])), -| (2, (((EmptyPtree, ([], Und)), []), []))] - -add_user 2; add_user 2; !states; -|val it = 1 : userID -|val it = 2 : userID -|val it = -| [(1, (((EmptyPtree, ([], Und)), []), [])), -| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))] - - -val cs = ((EmptyPtree, ([111], Und)), []) : calcstate; -upd_calc 1 cs; !states; -|val it = -| [(1, (((EmptyPtree, ([111], Und)), []), [])), -| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))] - -get_calc 1; get_calc 2; -|val it = ((EmptyPtree, ([111], Und)), []) : calcstate -|val it = ((EmptyPtree, ([], Und)), []) : calcstate - -del_user 2 3 (*non existent - NO msg!*); del_user 2 1; !states; -|val it = 3 : userID -|val it = 1 : userID -|val it = -| [(1, (((EmptyPtree, ([111], Und)), []), [])), -| (2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))] - -del_calc 1; !states; -|val it = 1 : calcID -|val it = [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))] - -add_calc e_calcstate; add_calc e_calcstate; !states; -|val it = 1 : calcID -|val it = 3 : calcID -|val it = -| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))])), -| (1, (((EmptyPtree, ([], Und)), []), [])), -| (3, (((EmptyPtree, ([], Und)), []), []))] - -add_user 2; !states; -|val it = -| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und)), (1, ([], Und))])), -| (1, (((EmptyPtree, ([], Und)), []), [])), -| (3, (((EmptyPtree, ([], Und)), []), []))] -*) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Frontend/interface.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Frontend/interface.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,843 @@ +(* the interface between the isac-kernel and the java-frontend; + the isac-kernel holds calc-trees; stdout in XML-format. + authors: Walther Neuper 2002 + (c) due to copyright terms + +use"Frontend/interface.sml"; +use"interface.sml"; +*) + +signature INTERFACE = + sig + val CalcTree : fmz list -> unit + val DEconstrCalcTree : calcID -> unit + val Iterator : calcID -> unit + val IteratorTEST : calcID -> iterID + val appendFormula : calcID -> cterm' -> unit + val autoCalculate : calcID -> auto -> unit + val checkContext : calcID -> pos' -> guh -> unit + val fetchApplicableTactics : calcID -> int -> pos' -> unit + val fetchProposedTactic : calcID -> unit + val applyTactic : calcID -> pos' -> tac -> unit + val getAccumulatedAsms : calcID -> pos' -> unit + val getActiveFormula : calcID -> unit + val getAssumptions : calcID -> pos' -> unit + val initContext : calcID -> ketype -> pos' -> unit + val getFormulaeFromTo : calcID -> pos' -> pos' -> int -> bool -> unit + val getTactic : calcID -> pos' -> unit + val interSteps : calcID -> pos' -> unit + val modifyCalcHead : calcID -> icalhd -> unit + val moveActiveCalcHead : calcID -> unit + val moveActiveDown : calcID -> unit + val moveActiveDownTEST : calcID -> unit + val moveActiveFormula : calcID -> pos' -> unit + val moveActiveLevelDown : calcID -> unit + val moveActiveLevelUp : calcID -> unit + val moveActiveRoot : calcID -> unit + val moveActiveRootTEST : calcID -> unit + val moveActiveUp : calcID -> unit + val moveCalcHead : calcID -> pos' -> unit + val moveDown : calcID -> pos' -> unit + val moveLevelDown : calcID -> pos' -> unit + val moveLevelUp : calcID -> pos' -> unit + val moveRoot : calcID -> unit + val moveUp : calcID -> pos' -> unit + val refFormula : calcID -> pos' -> unit + val replaceFormula : calcID -> cterm' -> unit + val resetCalcHead : calcID -> unit + val modelProblem : calcID -> unit + val refineProblem : calcID -> pos' -> guh -> unit + val setContext : calcID -> pos' -> guh -> unit + val setMethod : calcID -> metID -> unit + val setNextTactic : calcID -> tac -> unit + val setProblem : calcID -> pblID -> unit + val setTheory : calcID -> thyID -> unit + end + + +(*------------------------------------------------------------------*) +structure interface : INTERFACE = +struct +(*------------------------------------------------------------------*) + +(*.encode "Isabelle"-strings as seen by the user to the + format accepted by Isabelle. + encode "^" ---> "^^^"; see Knowledge/Atools.thy; + called for each cterm', icalhd, fmz in this interface; + + see "fun decode" in xmlsrc/mathml.sml.*) +fun encode (str:cterm') = + let fun enc [] = [] + | enc ("^"::cs) = "^"::"^"::"^"::(enc cs) + | enc (c::cs) = c::(enc cs) + in (implode o enc o explode) str:cterm' end; +fun encode_imodel (imodel:imodel) = + let fun enc (Given ifos) = Given (map encode ifos) + | enc (Find ifos) = Find (map encode ifos) + | enc (Relate ifos) = Relate (map encode ifos) + in map enc imodel:imodel end; +fun encode_icalhd ((pos', headl, imodel, pos_, spec):icalhd) = + (pos', encode headl, encode_imodel imodel, pos_, spec):icalhd; +fun encode_fmz ((ifos, spec):fmz) = (map encode ifos, spec):fmz; + + +(***. CalcTree .***) + +(** add and delete users **) + +(*.'Iterator 1' must exist with each CalcTree; + the only for updating the calc-tree + WN.0411: only 'Iterator 1' is stored, + all others are just calculated on the fly + TODO: adapt Iterator, add_user(= add_iterator!),etc. accordingly .*) +fun Iterator (cI:calcID) = (*returned ID unnecessary after WN.0411*) + (adduserOK2xml cI (add_user (cI:calcID))) + handle _ => sysERROR2xml cI "error in kernel"; +fun IteratorTEST (cI:calcID) = add_user (cI:calcID); +(*fun DEconstructIterator (cI:calcID) (uI:iterID) = + deluserOK2xml (del_user cI uI);*) + +(*.create a calc-tree; for calls from java: thus ^^^ decoded to ^; + compare "fun CalcTreeTEST" which does NOT decode.*) +fun CalcTree + [(fmz, sp):fmz] (*for several variants lateron*) = +(* val[(fmz,sp):fmz]=[(["fixedValues [r=Arbfix]","maximum A","valuesFor [a,b]", + "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]", + "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]", + "relations [A=a*b, a/2=r*sin alpha, b/2=r*cos alpha]", + "boundVariable a","boundVariable b","boundVariable alpha", + "interval {x::real. 0 <= x & x <= 2*r}", + "interval {x::real. 0 <= x & x <= 2*r}", + "interval {x::real. 0 <= x & x <= pi}", + "errorBound (eps=(0::real))"], + ("DiffApp.thy", ["maximum_of","function"], + ["DiffApp","max_by_calculus"]))]; + + *) + (let val cs = nxt_specify_init_calc (encode_fmz (fmz, sp)) + (*FIXME.WN.8.03: error-handling missing*) + val cI = add_calc cs + in calctreeOK2xml cI end) + handle _ => sysERROR2xml 0 "error in kernel"; + +fun DEconstrCalcTree (cI:calcID) = + deconstructcalctreeOK2xml (del_calc cI); + + +fun getActiveFormula (cI:calcID) = iteratorOK2xml cI (get_pos cI 1); + +fun moveActiveFormula (cI:calcID) (p:pos') = + let val ((pt,_),_) = get_calc cI + in if existpt' p pt then (upd_ipos cI 1 p; iteratorOK2xml cI p) + else sysERROR2xml cI "frontend sends a non-existing pos" end; + +(*. set the next tactic to be applied: dont't change the calc-tree, + but remember the envisaged changes for fun autoCalculate; + compare force NextTactic .*) +(* val (cI, tac) = (1, Add_Given "equality (x ^^^ 2 + 4 * x + 3 = 0)"); + val (cI, tac) = (1, Specify_Theory "PolyEq.thy"); + val (cI, tac) = (1, Specify_Problem ["normalize","polynomial", + "univariate","equation"]); + val (cI, tac) = (1, Subproblem ("Poly.thy", + ["polynomial","univariate","equation"])); + val (cI, tac) = (1, Model_Problem["linear","univariate","equation","test"]); + val (cI, tac) = (1, Detail_Set "Test_simplify"); + val (cI, tac) = (1, Apply_Method ["Test", "solve_linear"]); + val (cI, tac) = (1, Rewrite_Set "Test_simplify"); + *) +fun setNextTactic (cI:calcID) tac = + let val ((pt, _), _) = get_calc cI + val ip = get_pos cI 1 + in case locatetac tac (pt, ip) of +(* val ("ok", (tacis, c, (_,p'))) = locatetac tac (pt, ip); + *) + ("ok", (tacis, _, _)) => + (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "ok") + | ("unsafe-ok", (tacis, _, _)) => + (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "unsafe-ok") + | ("not-applicable",_) => setnexttactic2xml cI "not-applicable" + | ("end-of-calculation",_) => + setnexttactic2xml cI "end-of-calculation" + | ("failure",_) => sysERROR2xml cI "failure" + end; + +(*. apply a tactic at a position and update the calc-tree if applicable .*) +(*WN080226 java-code is missing, errors smltest/Knowledge/polyminus.sml*) +(* val (cI, ip, tac) = (1, p, hd appltacs); + val (cI, ip, tac) = (1, p, (hd (sel_appl_atomic_tacs pt p))); + *) +fun applyTactic (cI:calcID) ip tac = + let val ((pt, _), _) = get_calc cI + val p = get_pos cI 1 + in case locatetac tac (pt, ip) of +(* val ("ok", (tacis, c, (pt',p'))) = locatetac tac (pt, ip); + *) + ("ok", (_, c, ptp as (_,p'))) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p'; + autocalculateOK2xml cI p (if null c then p' + else last_elem c) p') + | ("unsafe-ok", (_, c, ptp as (_,p'))) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p'; + autocalculateOK2xml cI p (if null c then p' + else last_elem c) p') + | ("end-of-calculation", (_, c, ptp as (_,p'))) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p'; + autocalculateOK2xml cI p (if null c then p' + else last_elem c) p') + + + | (str,_) => autocalculateERROR2xml cI "failure" + end; + + + +(* val cI = 1; + *) +fun fetchProposedTactic (cI:calcID) = + (case step (get_pos cI 1) (get_calc cI) of + ("ok", (tacis, _, _)) => + let val _= upd_tacis cI tacis + val (tac,_,_) = last_elem tacis + in fetchproposedtacticOK2xml cI tac end + | ("helpless",_) => fetchproposedtacticERROR2xml cI "helpless" + | ("no-fmz-spec",_) => fetchproposedtacticERROR2xml cI "no-fmz-spec" + | ("end-of-calculation",_) => + fetchproposedtacticERROR2xml cI "end-of-calculation") + handle _ => sysERROR2xml cI "error in kernel"; + +(*datatype auto = FIXXXME040624: does NOT match interfaces/ITOCalc.java + Step of int (*1 do #int steps (may stop in model/specify) + IS VERY INEFFICIENT IN MODEL/SPECIY*) +| CompleteModel (*2 complete modeling + if model complete, finish specifying*) +| CompleteCalcHead (*3 complete model/specify in one go*) +| CompleteToSubpbl (*4 stop at the next begin of a subproblem, + if none, complete the actual (sub)problem*) +| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*) +| CompleteCalc; (*6 complete the calculation as a whole*)*) +fun autoCalculate (cI:calcID) auto = +(* val (cI, auto) = (1,CompleteCalc); + val (cI, auto) = (1,CompleteModel); + val (cI, auto) = (1,CompleteCalcHead); + val (cI, auto) = (1,Step 1); + *) + (let val pold = get_pos cI 1 + val x = autocalc [] pold (get_calc cI) auto + in + case x of +(* val (str, c, ptp as (_,p)) = x; + *) + ("ok", c, ptp as (_,p)) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p; + autocalculateOK2xml cI pold (if null c then pold + else last_elem c) p) + | ("end-of-calculation", c, ptp as (_,p)) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p; + autocalculateOK2xml cI pold (if null c then pold + else last_elem c) p) + | (str, _, _) => autocalculateERROR2xml cI str + end) + handle _ => sysERROR2xml cI "error in kernel"; + + +(* val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = + (1, (([],Pbl), "not used here", + [Given ["fixedValues [r=Arbfix]"], + Find ["maximum A", "valuesFor [a,b]"(*new input*)], + Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl, + ("DiffApp.thy", ["maximum_of","function"], + ["DiffApp","max_by_calculus"]))); + val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = + (1, (([],Pbl),"solve (x+1=2, x)", + [Given ["equality (x+1=2)", "solveFor x"], + Find ["solutions L"]], + Pbl, + ("Test.thy", ["linear","univariate","equation","test"], + ["Test","solve_linear"]))); + val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) = + (1, (([],Pbl),"solveTest (1+-1*2+x=0,x)", [], Pbl, ("", [], []))); + val (cI, p:pos')=(1, ([1],Frm)); + val (cI, p:pos')=(1, ([1,2,1,3],Res)); + *) +fun getTactic cI (p:pos') = + (let val ((pt,_),_) = get_calc cI + val (form, tac, asms) = pt_extract (pt, p) + in case tac of +(* val SOME ta = tac; + *) + SOME ta => gettacticOK2xml cI ta + | NONE => gettacticERROR2xml cI ("no tactic at position "^pos'2str p) + end) + handle _ => sysERROR2xml cI "syserror in getTactic"; + +(*. see ICalcIterator#fetchApplicableTactics + @see #TACTICS_ALL + @see #TACTICS_CURRENT_THEORY + @see #TACTICS_CURRENT_METHOD ..the only impl.WN040307.*) +(*. fetch tactics to be applied to a particular step.*) +(* WN071231 kept this version for later parametrisation*) +(*.version 1: fetch _all_ tactics from script .*) +fun fetchApplicableTactics cI (scope:int) (p:pos') = + (let val ((pt, _), _) = get_calc cI + in (applicabletacticsOK cI (sel_rules pt p)) + handle PTREE str => sysERROR2xml cI str + end) + handle _ => sysERROR2xml cI "error in kernel"; +(*.version 2: fetch _applicable_ _elementary_ (ie. recursively + decompose rule-sets) Rewrite*, Calculate .*) +fun fetchApplicableTactics cI (scope:int) (p:pos') = + (let val ((pt, _), _) = get_calc cI + in (applicabletacticsOK cI (sel_appl_atomic_tacs pt p)) + handle PTREE str => sysERROR2xml cI str + end) + handle _ => sysERROR2xml cI "error in kernel"; + +fun getAssumptions cI (p:pos') = + (let val ((pt,_),_) = get_calc cI + val (_, _, asms) = pt_extract (pt, p) + in getasmsOK2xml cI asms end) + handle _ => sysERROR2xml cI "syserror in getAssumptions"; + +(*WN0502 @see ME/ctree: type asms: illdesigned, thus no positions returned*) +fun getAccumulatedAsms cI (p:pos') = + (let val ((pt, _), _) = get_calc cI + val ass = map fst (get_assumptions_ pt p) + in (*getaccuasmsOK2xml cI (get_assumptions_ pt p)*) + getasmsOK2xml cI ass end) + handle _ => sysERROR2xml cI "syserror in getAccumulatedAsms"; + + +(*since moveActive* does NOT transfer pos java --> sml (only sml --> java) + refFormula might become involved in far-off errors !!!*) +fun refFormula cI (p:pos') = (*WN0501 rename to 'fun getElement' !*) +(* val (cI, uI) = (1,1); + *) + (let val ((pt,_),_) = get_calc cI + val (form, tac, asms) = pt_extract (pt, p) + in refformulaOK2xml cI p form end) + handle _ => sysERROR2xml cI "error in kernel"; + +(*.get formulae 'from' 'to' w.r.t. ordering in Position#compareTo(Position p); + in case of CalcHeads only the headline is taken + (the pos' allows distinction between PrfObj and PblObj anyway); + 'level' is adjusted such that an 'interval' of formulae is returned; + 'from' 'to' are designed for use by iterators of calcChangedEvent; + thus 'from' is the last unchanged position.*) +fun getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Pbl):pos')_ false = +(*special case because 'from' is _before_ the first elements to be returned*) +(* val (cI, from, to, level) = (1, ([],Pbl), ([],Pbl), 1); + *) + ((let val ((pt,_),_) = get_calc cI + val (ModSpec (_,_,headline,_,_,_),_,_) = pt_extract (pt, to) + in getintervalOK cI [(to, headline)] end) + handle _ => sysERROR2xml cI "error in kernel") + + | getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Met):pos')_ false = + getFormulaeFromTo cI ([],Pbl) ([],Pbl) (~00000) false + + | getFormulaeFromTo cI (from:pos') (to:pos') level false = +(* val (cI, from, to, level) = (1, unc, gen, 0); + val (cI, from, to, level) = (1, unc, gen, 1); + val (cI, from, to, level) = (1, ([],Pbl), ([],Met), 1); + *) + (if from = to then sysERROR2xml cI "getFormulaeFromTo: From = To" + else + (case from of + ([],Res) => sysERROR2xml cI "getFormulaeFromTo does: moveDown \ + \from=([],Res) .. goes beyond result" + | _ => let val ((pt,_),_) = get_calc cI + val f = move_dn [] pt from + fun max (a,b) = if a < b then b else a + (*must reach margins ...*) + val lev = max (level, max (lev_of from, lev_of to)) + in getintervalOK cI (get_interval f to lev pt) end) + handle _ => sysERROR2xml cI "error in getFormulaeFromTo") + + | getFormulaeFromTo cI from to level true = + sysERROR2xml cI "getFormulaeFromTo impl.for formulae only,\ + \i.e. last arg only impl. for false, _NOT_ true"; + + +(* val (cI, ip) = (1, ([1,9], Res)); + val (cI, ip) = (1, ([], Res)); + val (cI, ip) = (1, ([2], Res)); + val (cI, ip) = (1, ([3,1], Res)); + val (cI, ip) = (1, ([1,2,1], Res)); + *) +fun interSteps cI ip = + (let val ((pt,p), tacis) = get_calc cI + in if (not o is_interpos) ip + then interStepsERROR cI "only formulae with position (_,Res) \ + \may have intermediate steps above them" + else let val ip' = lev_pred' pt ip +(* val (str, pt', lastpos) = detailstep pt ip; + *) + in case detailstep pt ip of + ("detailrls", pt(*, pos'forms*), lastpos) => + (upd_calc cI ((pt, p), tacis); + interStepsOK cI (*pos'forms*) ip' ip' lastpos) + | ("no-Rewrite_Set...", _, _) => + sysERROR2xml cI "no Rewrite_Set..." + | (_, _(*, pos'formshds*), lastpos) => + interStepsOK cI (*pos'formshds*) ip' ip' lastpos + end + end) + handle _ => sysERROR2xml cI "error in kernel"; + +fun modifyCalcHead (cI:calcID) (ichd as ((p,_),_,_,_,_):icalhd) = + (let val ((pt,_),_) = get_calc cI + val (pt, chd as (_,p_,_,_,_,_)) = input_icalhd pt ichd + in (upd_calc cI ((pt, (p,p_)), []); + modifycalcheadOK2xml cI chd) end) + handle _ => sysERROR2xml cI "error in kernel"; + +(*.at the activeFormula set the Model, the Guard and the Specification + to empty and return a CalcHead; + the 'origin' remains (for reconstructing all that).*) +fun resetCalcHead (cI:calcID) = + (let val (ptp,_) = get_calc cI + val ptp = reset_calchead ptp + in (upd_calc cI (ptp, []); + modifycalcheadOK2xml cI (get_ocalhd ptp)) end) + handle _ => sysERROR2xml cI "error in kernel"; + +(*.at the activeFormula insert all the Descriptions in the Model + (_not_ in the Guard) and return a CalcHead; + the Descriptions are for user-guidance; the rest of the items + are left empty for user-input; + includes a resetCalcHead for the Model and the Guard.*) +fun modelProblem (cI:calcID) = + (let val (ptp, _) = get_calc cI + val ptp = reset_calchead ptp + val (_, _, ptp) = nxt_specif Model_Problem ptp + in (upd_calc cI (ptp, []); + modifycalcheadOK2xml cI (get_ocalhd ptp)) end) + handle _ => sysERROR2xml cI "error in kernel"; + + +(*.set the context determined on a knowledgebrowser to the current calc.*) +fun setContext (cI:calcID) (ip as (_,p_):pos') (guh:guh) = + (case (implode o (take_fromto 1 4) o explode) guh of + "thy_" => +(* val (cI, ip as (_,p_), guh) = (1, p, "thy_isac_Test-rls-Test_simplify"); + *) + if member op = [Pbl,Met] p_ + then message2xml cI "thy-context not to calchead" + else if ip = ([],Res) then message2xml cI "no thy-context at result" + else if no_thycontext guh then message2xml cI ("no thy-context for '"^ + guh ^ "'") + else let val (ptp as (pt,pold),_) = get_calc cI + val is = get_istate pt ip + val subs = subs_from is "dummy" guh + val tac = guh2rewtac guh subs + in case locatetac tac (pt, ip) of (*='fun setNextTactic'+step*) + ("ok", (tacis, c, ptp as (_,p))) => +(* val (str, (tacis, c, ptp as (_,p))) = locatetac tac (pt, ip); + *) + (upd_calc cI ((pt,p), []); + autocalculateOK2xml cI pold (if null c then pold + else last_elem c) p) + | ("unsafe-ok", (tacis, c, ptp as (_,p))) => + (upd_calc cI ((pt,p), []); + autocalculateOK2xml cI pold (if null c then pold + else last_elem c) p) + | ("end-of-calculation",_) => + message2xml cI "end-of-calculation" + | ("failure",_) => sysERROR2xml cI "failure" + | ("not-applicable",_) => (*the rule comes from anywhere..*) + (case applicable_in ip pt tac of + + Notappl e => message2xml cI ("'" ^ tac2str tac ^ + "' not-applicable") + | Appl m => + let val (p,c,_,pt) = generate1 (assoc_thy"Isac.thy") + m Uistate ip pt + in upd_calc cI ((pt,p),[]); + autocalculateOK2xml cI pold (if null c then pold + else last_elem c) p + end) + end +(* val (cI, ip as (_,p_), guh) = (1, pos, guh); + *) + | "pbl_" => + let val pI = guh2kestoreID guh + val ((pt, _), _) = get_calc cI + (*val ip as (_, p_) = get_pos cI 1*) + in if member op = [Pbl, Met] p_ + then let val (pt, chd) = set_problem pI (pt, ip) + in (upd_calc cI ((pt, ip), []); + modifycalcheadOK2xml cI chd) end + else sysERROR2xml cI "setContext for pbl requires ActiveFormula \ + \on CalcHead" + end +(* val (cI, ip as (_,p_), guh) = (1, pos, "met_eq_lin"); + *) + | "met_" => + let val mI = guh2kestoreID guh + val ((pt, _), _) = get_calc cI + in if member op = [Pbl, Met] p_ + then let val (pt, chd) = set_method mI (pt, ip) + in (upd_calc cI ((pt, ip), []); + modifycalcheadOK2xml cI chd) end + else sysERROR2xml cI "setContext for met requires ActiveFormula \ + \on CalcHead" + end) + handle _ => sysERROR2xml cI "error in kernel"; + + +(*.specify the Method at the activeFormula and return a CalcHead + containing the Guard. + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*) +fun setMethod (cI:calcID) (mI:metID) = +(* val (cI, mI) = (1, ["Test","solve_linear"]); + *) + (let val ((pt, _), _) = get_calc cI + val ip as (_, p_) = get_pos cI 1 + in if member op = [Pbl,Met] p_ + then let val (pt, chd) = set_method mI (pt, ip) + in (upd_calc cI ((pt, ip), []); + modifycalcheadOK2xml cI chd) end + else sysERROR2xml cI "setMethod requires ActiveFormula on CalcHead" + end) + handle _ => sysERROR2xml cI "error in kernel"; + +(*.specify the Problem at the activeFormula and return a CalcHead + containing the Model; special case of checkContext; + WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem '.*) +fun setProblem (cI:calcID) (pI:pblID) = + (let val ((pt, _), _) = get_calc cI + val ip as (_, p_) = get_pos cI 1 + in if member op = [Pbl,Met] p_ + then let val (pt, chd) = set_problem pI (pt, ip) + in (upd_calc cI ((pt, ip), []); + modifycalcheadOK2xml cI chd) end + else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead" + end) + handle _ => sysERROR2xml cI "error in kernel"; + +(*.specify the Theory at the activeFormula and return a CalcHead; + special case of checkContext; + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*) +fun setTheory (cI:calcID) (tI:thyID) = + (let val ((pt, _), _) = get_calc cI + val ip as (_, p_) = get_pos cI 1 + in if member op = [Pbl,Met] p_ + then let val (pt, chd) = set_theory tI (pt, ip) + in (upd_calc cI ((pt, ip), []); + modifycalcheadOK2xml cI chd) end + else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead" + end) + handle _ => sysERROR2xml cI "error in kernel"; + + +(**. without update of CalcTree .**) + +(*.match the model of a problem at pos p + with the model-pattern of the problem with pblID*) +(*fun tryMatchProblem cI pblID = + (let val ((pt,_),_) = get_calc cI + val p = get_pos cI 1 + val chd = trymatch pblID pt p + in trymatchOK2xml cI chd end) + handle _ => sysERROR2xml cI "error in kernel";*) + +(*.refinement for the parent-problem of the position.*) +(* val (cI, (p,p_), guh) = (1, ([1],Res), "pbl_equ_univ"); + *) +fun refineProblem cI ((p,p_) : pos') (guh : guh) = + (let val pblID = guh2kestoreID guh + val ((pt,_),_) = get_calc cI + val pp = par_pblobj pt p + val chd = tryrefine pblID pt (pp, p_) + in matchpbl2xml cI chd end) + handle _ => sysERROR2xml cI "error in kernel"; + +(* val (cI, ifo) = (1, "-2 * 1 + (1 + x) = 0"); + val (cI, ifo) = (1, "x = 2"); + val (cI, ifo) = (1, "[x = 3 + -2*1]"); + val (cI, ifo) = (1, "-1 + x = 0"); + val (cI, ifo) = (1, "x - 4711 = 0"); + val (cI, ifo) = (1, "2+ -1 + x = 2"); + val (cI, ifo) = (1, " x - "); + val (cI, ifo) = (1, "(-3 * x + 4 * y + -1 * x * y) / (x * y)"); + val (cI, ifo) = (1, "(4 * y + -3 * x) / (x * y) + -1"); + *) +fun appendFormula cI (ifo:cterm') = + (let val cs = get_calc cI + val pos as (_,p_) = get_pos cI 1 + in case step pos cs of +(* val (str, cs') = step pos cs; + *) + ("ok", cs') => + (case inform cs' (encode ifo) of +(* val (str, (_, c, ptp as (_,p))) = inform cs' (encode ifo); + *) + ("ok", (_(*use in DG !!!*), c, ptp as (_,p))) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p; + appendformulaOK2xml cI pos (if null c then pos + else last_elem c) p) + | ("same-formula", (_, c, ptp as (_,p))) => + (upd_calc cI (ptp, []); upd_ipos cI 1 p; + appendformulaOK2xml cI pos (if null c then pos + else last_elem c) p) + | (msg, _) => appendformulaERROR2xml cI msg) + | (msg, cs') => appendformulaERROR2xml cI msg + end) + handle _ => sysERROR2xml cI "error in kernel"; + + + +(*.replace a formula with_in_ a calculation; + this situation applies for initial CAS-commands, too.*) +(* val (cI, ifo) = (2, "-1 + x = 0"); + val (cI, ifo) = (1, "-1 + x = 0"); + val (cI, ifo) = (1, "x - 1 = 0"); + val (cI, ifo) = (1, "x = 1"); + val (cI, ifo) = (1, "solve(x+1=2,x)"); + val (cI, ifo) = (1, "Simplify (2*a + 3*a)"); + val (cI, ifo) = (1, "Diff (x^2 + x + 1, x)"); + *) +fun replaceFormula cI (ifo:cterm') = + (let val ((pt, _), _) = get_calc cI + val p = get_pos cI 1 + in case inform (([], [], (pt, p)): calcstate') (encode ifo) of + ("ok", (_(*tacs used for DG ?*), c, ptp' as (pt',p'))) => +(* val (str, (_,c, ptp' as (pt',p')))= inform ([], [], (pt, p)) (encode ifo); + *) + let val unc = if null (fst p) then p else move_up [] pt p + val _ = upd_calc cI (ptp', []) + val _ = upd_ipos cI 1 p' + in replaceformulaOK2xml cI unc + (if null c then unc + else last_elem c) p'(*' NEW*) end + | ("same-formula", _) => + (*TODO.WN0501 MESSAGE !*) + replaceformulaERROR2xml cI "formula not changed" + | (msg, _) => replaceformulaERROR2xml cI msg + end) + handle _ => sysERROR2xml cI "error in kernel"; + + + +(***. CalcIterator + moveActive*: set the pos' of the active formula stored with the calctree + could take pos' as argument for consistency checks + move*: compute the new iterator from the old one on the fly + +.***) + +fun moveActiveRoot cI = + (let val _ = upd_ipos cI 1 ([],Pbl) + in iteratorOK2xml cI ([],Pbl) end) + handle e => sysERROR2xml cI "error in kernel"; +fun moveRoot cI = + (iteratorOK2xml cI ([],Pbl)) + handle e => sysERROR2xml cI ""; +fun moveActiveRootTEST cI = + (let val _ = upd_ipos cI 1 ([],Pbl) + in (*iteratorOK2xml cI ([],Pbl)*)() end) + handle e => sysERROR2xml cI "error in kernel"; + +(* val (cI, uI) = (1,1); + val (cI, uI) = (1,2); + *) +fun moveActiveDown cI = + ((let val ((pt,_),_) = get_calc cI +(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI); + val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI); + + print_depth 7;pt + *) + val ip' = move_dn [] pt (get_pos cI 1) + val _ = upd_ipos cI 1 ip' + in iteratorOK2xml cI ip' end) + handle (PTREE e) => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveDown cI (p:pos') = + ((let val ((pt,_),_) = get_calc cI +(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI); + val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI); + + print_depth 7;pt + *) + val ip' = move_dn [] pt p + in iteratorOK2xml cI ip' end) + handle (PTREE e) => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveActiveDownTEST cI = + let val ((pt,_),_) = get_calc cI + val ip = get_pos cI 1 + val ip' = (move_dn [] pt ip) + handle _ => ip + val _ = upd_ipos cI 1 ip' + in (*iteratorOK2xml cI uI*)() end; + +fun moveActiveLevelDown cI = + ((let val ((pt,_),_) = get_calc cI + val ip' = movelevel_dn [] pt (get_pos cI 1) + val _ = upd_ipos cI 1 ip' + in iteratorOK2xml cI ip' end) + handle (PTREE e) => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveLevelDown cI (p:pos') = + ((let val ((pt,_),_) = get_calc cI + val ip' = movelevel_dn [] pt p + in iteratorOK2xml cI ip' end) + handle (PTREE e) => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; + +fun moveActiveUp cI = + ((let val ((pt,_),_) = get_calc cI + val ip' = move_up [] pt (get_pos cI 1) + val _ = upd_ipos cI 1 ip' + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveUp cI (p:pos') = + ((let val ((pt,_),_) = get_calc cI + val ip' = move_up [] pt p + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; + +fun moveActiveLevelUp cI = + ((let val ((pt,_),_) = get_calc cI + val ip' = movelevel_up [] pt (get_pos cI 1) + val _ = upd_ipos cI 1 ip' + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveLevelUp cI (p:pos') = + ((let val ((pt,_),_) = get_calc cI + val ip' = movelevel_up [] pt p + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; + +fun moveActiveCalcHead cI = + ((let val ((pt,_),_) = get_calc cI + val ip' = movecalchd_up pt (get_pos cI 1) + val _ = upd_ipos cI 1 ip' + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; +fun moveCalcHead cI (p:pos') = + ((let val ((pt,_),_) = get_calc cI + val ip' = movecalchd_up pt p + in iteratorOK2xml cI ip' end) + handle PTREE e => iteratorERROR2xml cI) + handle _ => sysERROR2xml cI "error in kernel"; + + +(*.initContext Thy_ is conceptually impossible at [Pbl,Met] + and at positions with Check_Postcond and End_Trans; + at possible pos's there can be NO rewrite (returned as a context, too).*) +(* val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1], Frm)); + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([], Res)); + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([2], Res)); + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1,1], Frm)); + *) +fun initContext (cI:calcID) Thy_ (pos as (p,p_):pos') = + ((if member op = [Pbl,Met] p_ + then message2xml cI "thy-context not to calchead" + else if pos = ([],Res) then message2xml cI "no thy-context at result" + else let val cs as (ptp as (pt,_),_) = get_calc cI + in if exist_lev_on' pt pos + then let val pos' = lev_on' pt pos + val tac = get_tac_checked pt pos' + in if is_rewtac tac + then contextthyOK2xml cI (context_thy (pt,pos) tac) + else message2xml cI ("no thy-context at tac '" ^ + tac2str tac ^ "'") + end + else if is_curr_endof_calc pt pos + then case step pos cs of +(* val (str, (tacis, _, (pt,_))) = step pos cs; + val ("ok", (tacis, _, (pt,_))) = step pos cs; + *) + ("ok", (tacis, _, (pt,_))) => + let val tac = fst3 (last_elem tacis) + in if is_rewtac tac + then contextthyOK2xml + cI (context_thy ptp tac) + else message2xml cI ("no thy-context at tac '" ^ + tac2str tac ^ "'") + end + | (msg, _) => message2xml cI msg + else message2xml cI "no thy-context at this position" + end) + handle _ => sysERROR2xml cI "error in kernel") + +(* val (cI, Pbl_, pos as (p,p_)) = (1, Pbl_, ([],Pbl)); + *) + | initContext cI Pbl_ (pos as (p,p_):pos') = + ((let val ((pt,_),_) = get_calc cI + val pp = par_pblobj pt p + val chd = initcontext_pbl pt (pp,p_) + in matchpbl2xml cI chd end) + handle _ => sysERROR2xml cI "error in kernel") + + | initContext cI Met_ (pos as (p,p_):pos') = + ((let val ((pt,_),_) = get_calc cI + val pp = par_pblobj pt p + val chd = initcontext_met pt (pp,p_) + in matchmet2xml cI chd end) + handle _ => sysERROR2xml cI "error in kernel"); + + + +(*.match a theorem, a ruleset (etc., selected in the knowledge-browser) +with the formula in the focus on the worksheet; +string contains the thy, thus it is unique as thmID, rlsID for this thy; +take the substitution from the istate of the formula.*) +(* use"../smltest/Knowledge/poly.sml"; + val (cI, pos as (p,p_), guh) = (1, ([1,1,1], Frm), + "thy_Poly-thm-real_diff_minus"); + val (cI, pos as (p,p_), guh) = (1, ([1,1], Frm), "norm_Poly"); + val (cI, pos as (p,p_), guh) = + (1, ([1], Res), "thy_isac_Test-rls-Test_simplify"); + *) +fun checkContext (cI:calcID) (pos:pos' as (p,p_)) (guh:guh) = + (case (implode o (take_fromto 1 4) o explode) guh of + "thy_" => + if member op = [Pbl,Met] p_ + then message2xml cI "thy-context not to calchead" + else if pos = ([],Res) then message2xml cI "no thy-context at result" + else if no_thycontext guh then message2xml cI ("no thy-context for '"^ + guh ^ "'") + else let val (ptp as (pt,_),_) = get_calc cI + val is = get_istate pt pos + val subs = subs_from is "dummy" guh + val tac = guh2rewtac guh subs + in contextthyOK2xml cI (context_thy (pt, pos) tac) end + + (*.match the model of a problem at pos p + with the model-pattern of the problem with pblID.*) +(* val (cI, pos:pos' as (p,p_), guh) = + (1, p, kestoreID2guh Pbl_ ["univariate","equation"]); + val (cI, pos:pos' as (p,p_), guh) = + (1, ([],Pbl), kestoreID2guh Pbl_ ["univariate","equation"]); + val (cI, pos:pos' as (p,p_), guh) = + (1, ([],Pbl), "pbl_equ_univ"); + *) + | "pbl_" => + let val ((pt,_),_) = get_calc cI + val pp = par_pblobj pt p + val keID = guh2kestoreID guh + val chd = context_pbl keID pt pp + in matchpbl2xml cI chd end +(* val (cI, pos:pos' as (p,p_), guh) = + (1, ([],Pbl), kestoreID2guh Met_ ["LinEq", "solve_lineq_equation"]); + *) + | "met_" => + let val ((pt,_),_) = get_calc cI + val pp = par_pblobj pt p + val keID = guh2kestoreID guh + val chd = context_met keID pt pp + in matchmet2xml cI chd end) + handle _ => sysERROR2xml cI "error in kernel"; + + +(*------------------------------------------------------------------*) +end +open interface; +(*------------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Frontend/messages.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Frontend/messages.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,43 @@ +(* all messages are encoded to integers for the multi-language system + use"Frontend/messages.sml"; + use"messages.sml"; + *) + +datatype language = English | German | Japanese; +fun language2str English = "English" + | language2str German = "German" + | language2str Japanese = "Japanese"; + +val language = English; + +(*1000 system*) +fun msg2str 1000 English = + "msg 1000 English" + | msg2str 1000 German = + "msg 1000 German" + +(*2000 user in model- and specify-phase*) + | msg2str 2020 English = + "Kernel cannot propose a tactic (helpless!)" + + +(*3000 user in solve-phase*) + +(*4000 general*) + +(*5000 general*) + +(*6000 general*) + +(*7000 general*) + +(*1000 general*) + +(*1000 general*) + +(*1000 general*) + +(*1000 general*) + + | msg2str i l = raise error ("no message for No. "^ + string_of_int i^" "^language2str l); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Frontend/states.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Frontend/states.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,487 @@ +(* states for calculation in global refs + use"../states.sml"; + use"states.sml"; + *) + +(* +type hide = (pblID * + string list * (*hide: tacs + + "ALL", .. result immediately + "MODELPBL", .. modeling hidden + "SPEC", .. specifying hidden + "MODELMET", .. (additional itms !) + "APPLY", .. solving hidden + detail: rls + "Rewrite_*" (as strings) must _not_ be .. + .. contained in this list, rls _only_ !*) + bool) (*inherit to children in pbl-herarchy*) + list; + +(*. points a pbl/metID to a sub-hierarchy of key ?.*) +fun is_child_of child key = + let fun is_ch [] [] = true (*is child of itself*) + | is_ch (c::_) [] = true + | is_ch [] (k::_) = false + | is_ch (c::cs) (k::ks) = + if c = k then is_ch cs ks else false + in is_ch (rev child) (rev key) end; +(* +is_child_of ["root","univar","equation"] ["univar","equation"]; +val it = true : bool +is_child_of ["root","univar","equation"] ["system","equation"]; +val it = false : bool +is_child_of ["equation"] ["system","equation"]; +val it = false : bool +is_child_of ["root","univar","equation"] ["linear","univar","equation"]; +val it = false : bool +*) + +(*.what tactics have to be hidden (in model/specify these may be several).*) +datatype hid = + Show (**) + | Hundef (**) + | Htac (*a tactic has to be hidden*) + | Hmodel (*the model of the (sub)problem has to be hidden*) + | Hspecify (*the specification of the (sub)problem has to be hidden*) + | Happly; (*solving the (sub)problem has to be hidden*) + +(*. search all pbls if there is some tactic or model/spec/calc to hide .*) +fun is_hid pblID arg [] = Show + | is_hid pblID arg ((pblID', strs, inherit)::pts) = + let fun is_mem arg = + if arg mem strs then Htac + else if arg mem ["Add_Given","Add_Find","Add_Relation"] + andalso "MODEL" mem strs then Hmodel + else if arg mem ["Specify_Theory","Specify_Problem", + "Specify_Method"] + andalso "SPEC" mem strs then Hspecify + else if "APPLY" mem strs then Htac + else Hundef + in if inherit then + if is_child_of (pblID:pblID) pblID' + then case is_mem arg of Hundef => is_hid pblID arg (pts:hide) + | hid => hid + else is_hid pblID arg pts + else if pblID = pblID' + then case is_mem arg of Hundef => is_hid pblID arg (pts:hide) + | hid => hid + else is_hid pblID arg pts + end; +(*val hide = [([],["Refine_Tacitly"],true), + (["univar","equation"],["Apply_Method","Model_Problem","SPEC"], + false)] + :hide; +is_hid [] "Rewrite" hide; +val it = Show +is_hid ["any","problem"] "Refine_Tacitly" hide; +val it = Htac +is_hid ["root","univar","equation"] "Apply_Method" hide; +val it = Show +is_hid ["univar","equation"] "Apply_Method" hide; +val it = Htac +is_hid ["univar","equation"] "Specify_Problem" hide; +val it = Hspecify +*) + +fun is_hide pblID (tac as (Subproblem (_,pI))) (det:detail) = + is_hid pblID "SELF" det + | is_hide pblID (tac as (Rewrite (thmID,_))) det = + is_hid pblID thmID det + | is_hide pblID (tac as (Rewrite_Inst (_,(thmID,_)))) det = + is_hid pblID thmID det + | is_hide pblID (tac as (Rewrite_Set rls)) det = + is_hid pblID rls det + | is_hide pblID (tac as (Rewrite_Set_Inst (_,rls))) det = + is_hid pblID rls det + | is_hide pblID tac det = is_hid pblID (tac2IDstr tac) det; +(*val hide = [([],["Refine_Tacitly"],true), + (["univar","equation"],["Apply_Method","Model_Problem", + "SPEC","SELF"], + false)] + :hide; +is_hide [] (Rewrite ("","")) hide; +val it = Show +is_hide ["any","problem"] (Refine_Tacitly []) hide; +val it = Htac +is_hide ["root","univar","equation"] (Apply_Method []) hide; +val it = Show +is_hide ["univar","equation"] (Apply_Method []) hide; +val it = Htac +is_hide ["univar","equation"] (Specify_Problem []) hide; +val it = Hspecify +is_hide ["univar","equation"] (Subproblem (e_domID,["univar","equation"]))hide; +val it = Htac +is_hide ["equation"] (Subproblem (e_domID,["univar","equation"]))hide; +val it = Show +*) + + +(*. search all pbls in detail if there is some rls' to be detailed .*) +fun is_det pblID arg [] = false + | is_det pblID arg ((pblID', rlss, inherit)::pts) = + if inherit then + if is_child_of (pblID:pblID) pblID' + then if arg mem rlss then true + else is_det pblID arg (pts:detail) + else is_det pblID arg pts + else if pblID = pblID' + then if arg mem rlss then true + else is_det pblID arg (pts:detail) + else is_det pblID arg pts; + +(*fun is_detail pblID (tac as (Subproblem (_,pI))) (det:detail) = + is_det pblID "SELF" det*) +fun is_detail pblID (tac as (Rewrite_Set rls)) det = + is_det pblID rls det + | is_detail pblID (tac as (Rewrite_Set_Inst (_,rls))) det = + is_det pblID rls det + | is_detail _ _ _ = false; +----------------------------------------*) + +type iterID = int; +type calcID = int; + +(*FIXME.WN.9.03: ev. resdesign calcstate + pos for CalcIterator +type state = + (*pos' * set by the CalcIterator ---> for each user*) + calcstate; (*to which ev.included 'preview' tac_s could be applied*) +val e_state = (e_pos', e_calcstate):state; +val states = ref ([]:(iterID * (calcID * state) list) list); +*) + +val states = + ref ([]:(calcID * + (calcstate * + (iterID * (*1 sets the 'active formula'*) + pos' (*for iterator of a user *) + ) list)) list); +(* +states:= [(3,(e_calcstate, [(1,e_pos'), + (3,e_pos')])), + (4,(e_calcstate, [(1,e_pos'), + (2,e_pos')]))]; +*) + +(** create new instances of users and ptrees + new keys are the lowest possible in the association list **) + +(* add users *) +fun new_key u n = case assoc (u, n) of + NONE => n +| SOME _ => new_key u (n+1); +(*///10.10 +fun get_calcID (u:(calcID * (calcstate * (iterID * pos') list)) list) = + (new_key u 1):calcID;*) +(* +val new_iterID = get_calcID (!states); +val it = 1 : int +states:= (!states) @ [(new_iterID, [])]; +!states; +val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[])] +*) + +(*///7.10.03/// add states to a users active states +fun get_calcID (uI:iterID) (p:(iterID * (calcID * state) list) list) = + case assoc (p, uI) of + NONE => raise error ("get_calcID: no iterID " ^ + (string_of_int uI)) + | SOME ps => (new_key ps 1):calcID; +> get_calcID 1 (!states); +val it = 1 : calcID +*) +(* add users to a calcstate *) +fun get_iterID (cI:calcID) + (p:(calcID * (calcstate * (iterID * pos') list)) list) = + case assoc (p, cI) of + NONE => raise error ("get_iterID: no iterID " ^ (string_of_int cI)) + | SOME (_, us) => (new_key us 1):iterID; +(* get_iterID 3 (!states); +val it = 2 : iterID*) + + +(** retrieve, update, delete a state by iterID, calcID **) + +(*//////7.10. +fun get_cal (uI:iterID) (pI:calcID) (p:(iterID * (calcID * state) list) list) = + (the (assoc2 (p,(uI, pI)))) + handle _ => raise error ("get_state " ^ (string_of_int uI) ^ + " " ^ (string_of_int pI) ^ " not existent"); +> get_cal 3 1 (!states); +val it = (((EmptyPtree,(#,#)),[]),([],[])) : state +*) + +(*///7.10. +fun get_state (uI:iterID) (pI:calcID) = get_cal uI pI (!states); +fun get_calc (uI:iterID) (pI:calcID) = (snd o (get_cal uI pI)) (!states); +*) +fun get_calc (cI:calcID) = + case assoc (!states, cI) of + NONE => raise error ("get_calc "^(string_of_int cI)^" not existent") + | SOME (c, _) => c; +fun get_pos (cI:calcID) (uI:iterID) = + case assoc (!states, cI) of + NONE => raise error ("get_pos: calc " ^ (string_of_int cI) + ^ " not existent") + | SOME (_, us) => + (case assoc (us, uI) of + NONE => raise error ("get_pos: user " ^ (string_of_int uI) + ^ " not existent") + | SOME p => p); + + +fun del_assoc ([],_) = [] + | del_assoc a = + let fun del ([], key) ps = ps + | del ((keyi, xi) :: pairs, key) ps = + if key = keyi then ps @ pairs + else del (pairs, key) (ps @ [(keyi, xi)]) + in del a [] end; +(* +> val ps = [(1,"1"),(2,"2"),(3,"3"),(4,"4")]; +> del_assoc (ps,3); +val it = [(1,"1"),(2,"2"),(4,"4")] : (int * string) list +*) + +(* delete doesn't report non existing elements *) +(*/////7.10. +fun del_assoc2 (uI:iterID) (pI:calcID) ps = + let val new_ps = del_assoc (the (assoc (ps, uI)), pI) + in overwrite (ps, (uI, new_ps)) end;*) +(* +> states:= del_assoc2 4 41 (!states); +> !states; +val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#)]),(1,[(#,#)])] : states + +> del_user 3; +> !states; +val it = [(4,[(#,#)]),(1,[(#,#)])] : states +*) +fun del_assoc2 (cI:calcID) (uI:iterID) ps = + case assoc (ps, cI) of + NONE => ps + | SOME (cs, us) => + overwrite (ps, (cI, (cs, del_assoc (us, uI)))); +(* +> del_assoc2 4 1 (!states); +val it = + [(3, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (3, ([], Und))])), + (4, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]*) + +(*///7.10. +fun overwrite2 (ps, (((uI:iterID), (pI:calcID)), p)) = + let val new_ps = overwrite (the (assoc (ps, uI)), (pI, p)) + in (overwrite (ps, (uI, new_ps))) + handle _ => raise error ("overwrite2 " ^ (string_of_int uI) ^ + " " ^ (string_of_int pI) ^ " not existent") + end;*) +fun overwrite2 (ps, (((cI:calcID), (uI:iterID)), p)) = + case assoc (ps, cI) of + NONE => + raise error ("overwrite2: calc " ^ (string_of_int uI) ^" not existent") + | SOME (cs, us) => + overwrite (ps, (cI ,(cs, overwrite (us, (uI, p))))); + +fun upd_calc (cI:calcID) cs = + case assoc (!states, cI) of + NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent") + | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us))); +(*WN051210 testing before initac: only 1 taci in calcstate so far: +fun upd_calc (cI:calcID) (cs as (_, tacis):calcstate) = + (if length tacis > 1 + then raise error ("upd_calc, |tacis|>1: "^tacis2str tacis) + else (); + case assoc (!states, cI) of + NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent") + | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us))) + );*) + + +(*///7.10. +fun upd_tacis (uI:iterID) (pI:calcID) tacis = + let val (p, (ptp,_)) = get_state uI pI + in states:= + overwrite2 ((!states), ((uI, pI), (p, (ptp, tacis)))) end;*) +fun upd_tacis (cI:calcID) tacis = + case assoc (!states, cI) of + NONE => + raise error ("upd_tacis: calctree "^(string_of_int cI)^" not existent") + | SOME ((ptp,_), us) => + states:= overwrite (!states, (cI, ((ptp, tacis), us))); +(*///7.10. +fun upd_ipos (uI:iterID) (pI:calcID) (ip:pos') = + let val (_, calc) = get_state uI pI + in states:= overwrite2 ((!states), ((uI, pI), (ip, calc))) end;*) +fun upd_ipos (cI:calcID) (uI:iterID) (ip:pos') = + case assoc (!states, cI) of + NONE => + raise error ("upd_ipos: calctree "^(string_of_int cI)^" not existent") + | SOME (cs, us) => + states:= overwrite2 (!states, ((cI, uI), ip)); + + +(** add and delete calcs **) + +(*///7.10 +fun add_pID (uI:iterID) (s:state) (p:(iterID * (calcID * state) list) list) = + let val new_ID = get_calcID uI p; + val new_states = (the (assoc (p, uI))) @ [(new_ID, s)]; + in (new_ID, (overwrite (p, (uI, new_states)))) end;*) +(* +> val (new_calcID, new_states) = add_pID 1 (!states); +> states:= new_states; +> !states; +val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states +> val (new_calcID, new_states) = add_pID 3 (!states); +> states:= new_states; +> !states; +val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states +> assoc2 (!states, (3, 1)); +val it = SOME EmptyPtree : ptree option +> assoc2 (!states, (3, 2)); +val it = NONE : ptree option +*) +(*///7.10 +fun add_calc (uI:iterID) (s:state) = + let val (new_calcID, new_calcs) = add_pID uI s (!states) + in states:= new_calcs; + new_calcID end; *) +fun add_user (cI:calcID) = + case assoc (!states, cI) of + NONE => + raise error ("add_user: calctree "^(string_of_int cI)^" not existent") + | SOME (cs, us) => + let val new_uI = new_key us 1 + in states:= overwrite2 (!states, ((cI, new_uI), e_pos')); + new_uI:iterID end; + +(*///10.10. +fun del_calc (uI:iterID) (pI:calcID) = + (states:= del_assoc2 uI pI (!states); pI);*) +fun del_user (cI:calcID) (uI:iterID) = + (states:= del_assoc2 cI uI (!states); uI); + + +(** add and delete calculations **) +(**///7.10 add and delete users **) +(*///7.10 +fun add_user () = + let val new_uI = get_calcID (!states) + in states:= (!states) @ [(new_uI, [])]; + new_uI end;*) +fun add_calc (cs:calcstate) = + let val new_cI = new_key (!states) 1 + in states:= (!states) @ [(new_cI, (cs, []))]; + new_cI:calcID end; + +(* delete doesn't report non existing elements *) +(*///7.10 +fun del_user (uI:userID) = + (states:= del_assoc (!states, uI); uI);*) +fun del_calc (cI:calcID) = + (states:= del_assoc (!states, cI); cI:calcID); + +(* -------------- test all exported funs -------------- +///7.10 +Compiler.Control.Print.printDepth:=8; +states:=[]; +add_user (); add_user (); !states; +ML> val it = 1 : userID +ML> val it = 2 : userID +ML> val it = [(1,[]),(2,[])] + +val (hide,detail) = ([(["pI"],["tac"],true)]:hide, + [(["pI"],["tac"],true)]:detail); +add_calc 1 e_state; +add_calc 1 (e_calcstate,(hide,detail)); !states; +ML> val it = 1 : calcID +ML> val it = 2 : calcID +ML> val it = + [(1, + [(1,(((EmptyPtree,(#,#)),[]),([],[]))), + (2,(((EmptyPtree,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])] + +val (pt,(p,p_)) = (EmptyPtree,e_pos'); +val (pt,_) = cappend_problem pt p Uistate ([],e_spec); +upd_calc 1 2 ((pt,(p,p_)),[]); !states; +ML> val it = + [(1, + [(1,(((EmptyPtree,(#,#)),[]),([],[]))), + (2,(((Nd #,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])] +(* ~~~~~~~~~~~~~~~~~~~~ unchanged !!!*) + +get_state 1 1; get_state 1 2; +ML> val it = (((EmptyPtree,([],Und)),[]),([],[])) : state +ML> val it = + (((Nd + (PblObj + {branch=NoBranch,cell=[],env=(#,#,#,#),loc=(#,#),meth=[], + model={Find=#,Given=#,Relate=#,Where=#,With=#},origin=(#,#), + ostate=Incomplete,probl=[],result=(#,#),spec=(#,#,#)},[]),([],Und)), + []),([(["pI"],["tac"],true)],[(["pI"],["tac"],true)])) : state + +del_calc 2 1 (*non existent - NO msg!*); del_calc 1 2; !states; +ML> val it = [(1,[(1,(((EmptyPtree,(#,#)),[]),([],[])))]),(2,[])] + +del_user 1; !states; +ML> val it = [(2,[])] + +add_user (); add_user (); !states; +ML> val it = 1 : userID +ML> val it = 3 : userID +ML> val it = [(2,[]),(1,[]),(3,[])] +*) + + +(* -------------- test all exported funs -------------- +print_depth 9; +states:=[]; +add_calc e_calcstate; add_calc e_calcstate; !states; +|val it = 1 : calcID +|val it = 2 : calcID +|val it = +| [(1, (((EmptyPtree, ([], Und)), []), [])), +| (2, (((EmptyPtree, ([], Und)), []), []))] + +add_user 2; add_user 2; !states; +|val it = 1 : userID +|val it = 2 : userID +|val it = +| [(1, (((EmptyPtree, ([], Und)), []), [])), +| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))] + + +val cs = ((EmptyPtree, ([111], Und)), []) : calcstate; +upd_calc 1 cs; !states; +|val it = +| [(1, (((EmptyPtree, ([111], Und)), []), [])), +| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))] + +get_calc 1; get_calc 2; +|val it = ((EmptyPtree, ([111], Und)), []) : calcstate +|val it = ((EmptyPtree, ([], Und)), []) : calcstate + +del_user 2 3 (*non existent - NO msg!*); del_user 2 1; !states; +|val it = 3 : userID +|val it = 1 : userID +|val it = +| [(1, (((EmptyPtree, ([111], Und)), []), [])), +| (2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))] + +del_calc 1; !states; +|val it = 1 : calcID +|val it = [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))] + +add_calc e_calcstate; add_calc e_calcstate; !states; +|val it = 1 : calcID +|val it = 3 : calcID +|val it = +| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))])), +| (1, (((EmptyPtree, ([], Und)), []), [])), +| (3, (((EmptyPtree, ([], Und)), []), []))] + +add_user 2; !states; +|val it = +| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und)), (1, ([], Und))])), +| (1, (((EmptyPtree, ([], Und)), []), [])), +| (3, (((EmptyPtree, ([], Und)), []), []))] +*) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/appl.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/appl.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,782 @@ +(* use"ME/appl.sml"; + use"appl.sml"; + +12345678901234567890123456789012345678901234567890123456789012345678901234567890 + 10 20 30 40 50 60 70 80 +*) +val e_cterm' = empty_cterm'; + + +fun rew_info (Rls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = + (rew_ord':rew_ord',erls,ca) + | rew_info (Seq {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = + (rew_ord',erls,ca) + | rew_info (Rrls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = + (rew_ord',erls, ca) + | rew_info rls = raise error ("rew_info called with '"^rls2str rls^"'"); + +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_thm after rls' --> rls*) +fun from_pblobj_or_detail_thm thm' p pt = + let val (pbl,p',rls') = par_pbl_det pt p + in if pbl + then let (*val _= writeln("### from_pblobj_or_detail_thm: pbl=true")*) + val thy' = get_obj g_domID pt p' + val {rew_ord',erls,(*asm_thm,*)...} = + get_met (get_obj g_metID pt p') + (*val _= writeln("### from_pblobj_or_detail_thm: metID= "^ + (metID2str(get_obj g_metID pt p'))) + val _= writeln("### from_pblobj_or_detail_thm: erls= "^erls)*) + in ("OK",thy',rew_ord',erls,(*put_asm*)false) + end + else ((*writeln("### from_pblobj_or_detail_thm: pbl=false");*) + (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize !!! + NONE => ("unknown ruleset '"^rls'^"'","","",Erls,false) + | SOME rls =>*) + let val thy' = get_obj g_domID pt (par_pblobj pt p) + val (rew_ord',erls,(*asm_thm,*)_) = rew_info rls' + in ("OK",thy',rew_ord',erls,false) end) + end; +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_calc after rls' --> rls*) +fun from_pblobj_or_detail_calc scrop p pt = +(* val (scrop, p, pt) = (op_, p, pt); + *) + let val (pbl,p',rls') = par_pbl_det pt p + in if pbl + then let val thy' = get_obj g_domID pt p' + val {calc = scr_isa_fns,...} = + get_met (get_obj g_metID pt p') + val opt = assoc (scr_isa_fns, scrop) + in case opt of + SOME isa_fn => ("OK",thy',isa_fn) + | NONE => ("applicable_in Calculate: unknown '"^scrop^"'", + "",("",e_evalfn)) end + else (*case assoc(!ruleset', rls') of + NONE => ("unknown ruleset '"^rls'^"'","",("",e_evalfn)) + | SOME rls => !!!FIXME.3.4.03:re-organize from_pblobj_or_detai*) + (* val SOME rls = assoc(!ruleset', rls'); + *) + let val thy' = get_obj g_domID pt (par_pblobj pt p); + val (_,_,(*_,*)scr_isa_fns) = rew_info rls'(*rls*) + in case assoc (scr_isa_fns, scrop) of + SOME isa_fn => ("OK",thy',isa_fn) + | NONE => ("applicable_in Calculate: unknown '"^scrop^"'", + "",("",e_evalfn)) end + end; +(*------------------------------------------------------------------*) + +val op_and = Const ("op &", [bool, bool] ---> bool); +(*> (cterm_of thy) (op_and $ Free("a",bool) $ Free("b",bool)); +val it = "a & b" : cterm +*) +fun mk_and a b = op_and $ a $ b; +(*> (cterm_of thy) + (mk_and (Free("a",bool)) (Free("b",bool))); +val it = "a & b" : cterm*) + +fun mk_and [] = HOLogic.true_const + | mk_and (t::[]) = t + | mk_and (t::ts) = + let fun mk t' (t::[]) = op_and $ t' $ t + | mk t' (t::ts) = mk (op_and $ t' $ t) ts + in mk t ts end; +(*> val pred = map (term_of o the o (parse thy)) + ["#0 <= #9 + #4 * x","#0 <= sqrt x + sqrt (#-3 + x)"]; +> (cterm_of thy) (mk_and pred); +val it = "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)" : cterm*) + + + + +(*for Check_elementwise in applicable_in: [x=1,..] Assumptions -> (x,0<=x&..)*) +fun mk_set thy pt p (Const ("List.list.Nil",_)) pred = (e_term, []) + + | mk_set thy pt p (Const ("Tools.UniversalList",_)) pred = + (e_term, if pred <> Const ("Script.Assumptions",bool) + then [pred] + else (map fst) (get_assumptions_ pt (p,Res))) + +(* val pred = (term_of o the o (parse thy)) pred; + val consts as Const ("List.list.Cons",_) $ eq $ _ = ft; + mk_set thy pt p consts pred; + *) + | mk_set thy pt p (consts as Const ("List.list.Cons",_) $ eq $ _) pred = + let val (bdv,_) = HOLogic.dest_eq eq; + val pred = if pred <> Const ("Script.Assumptions",bool) + then [pred] + else (map fst) (get_assumptions_ pt (p,Res)) + in (bdv, pred) end + + | mk_set thy _ _ l _ = + raise error ("check_elementwise: no set "^ + (Syntax.string_of_term (thy2ctxt thy) l)); +(*> val consts = str2term "[x=#4]"; +> val pred = str2term "Assumptions"; +> val pt = union_asm pt p + [("#0 <= sqrt x + sqrt (#5 + x)",[11]),("#0 <= #9 + #4 * x",[22]), + ("#0 <= x ^^^ #2 + #5 * x",[33]),("#0 <= #2 + x",[44])]; +> val p = []; +> val (sss,ttt) = mk_set thy pt p consts pred; +> (Syntax.string_of_term (thy2ctxt thy) sss,Syntax.string_of_term(thy2ctxt thy) ttt); +val it = ("x","((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & ... + + val consts = str2term "UniversalList"; + val pred = str2term "Assumptions"; + +*) + + + +(*check a list (/set) of constants [c_1,..,c_n] for c_i:set (: in)*) +(* val (erls,consts,(bdv,pred)) = (erl,ft,vp); + val (consts,(bdv,pred)) = (ft,vp); + *) +fun check_elementwise thy erls all_results (bdv, asm) = + let (*bdv extracted from ~~~~~~~~~~~ in mk_set already*) + fun check sub = + let val inst_ = map (subst_atomic [sub]) asm + in case eval__true thy 1 inst_ [] erls of + (asm', true) => ([HOLogic.mk_eq sub], asm') + | (_, false) => ([],[]) + end; + (*val _= writeln("### check_elementwise: res= "^(term2str all_results)^ + ", bdv= "^(term2str bdv)^", asm= "^(terms2str asm));*) + val c' = isalist2list all_results + val c'' = map (snd o HOLogic.dest_eq) c' (*assumes [x=1,x=2,..]*) + val subs = map (pair bdv) c'' + in if asm = [] then (all_results, []) + else ((apfst ((list2isalist bool) o flat)) o + (apsnd flat) o split_list o (map check)) subs end; +(* 20.5.03 +> val all_results = str2term "[x=a+b,x=b,x=3]"; +> val bdv = str2term "x"; +> val asm = str2term "(x ~= a) & (x ~= b)"; +> val erls = e_rls; +> val (t, ts) = check_elementwise thy erls all_results (bdv, asm); +> term2str t; writeln(terms2str ts); +val it = "[x = a + b, x = b, x = c]" : string +["a + b ~= a & a + b ~= b","b ~= a & b ~= b","c ~= a & c ~= b"] +... with appropriate erls this should be: +val it = "[x = a + b, x = c]" : string +["b ~= 0 & a ~= 0", "3 ~= a & 3 ~= b"] + ////// because b ~= b False*) + + + +(*before 5.03----- +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #3) + sqrt (#5 - #3)) &\ + \ #0 <= #25 + #-1 * #3 ^^^ #2) & #0 <= #4"; +> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct; +val ct' = "True" : cterm' + +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #-3) + sqrt (#5 - #-3)) &\ + \ #0 <= #25 + #-1 * #-3 ^^^ #2) & #0 <= #4"; +> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct; +val ct' = "True" : cterm' + + +> val const = (term_of o the o (parse thy)) "(#3::real)"; +> val pred' = subst_atomic [(bdv,const)] pred; + + +> val consts = (term_of o the o (parse thy)) "[x = #-3, x = #3]"; +> val bdv = (term_of o the o (parse thy)) "(x::real)"; +> val pred = (term_of o the o (parse thy)) + "((#0 <= #18 & #0 <= sqrt (#5 + x) + sqrt (#5 - x)) & #0 <= #25 + #-1 * x ^^^ #2) & #0 <= #4"; +> val ttt = check_elementwise thy consts (bdv, pred); +> (cterm_of thy) ttt; +val it = "[x = #-3, x = #3]" : cterm + +> val consts = (term_of o the o (parse thy)) "[x = #4]"; +> val bdv = (term_of o the o (parse thy)) "(x::real)"; +> val pred = (term_of o the o (parse thy)) + "#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #5 * x & #0 <= #2 + x"; +> val ttt = check_elementwise thy consts (bdv,pred); +> (cterm_of thy) ttt; +val it = "[x = #4]" : cterm + +> val consts = (term_of o the o (parse thy)) "[x = #-12 // #5]"; +> val bdv = (term_of o the o (parse thy)) "(x::real)"; +> val pred = (term_of o the o (parse thy)) + " #0 <= sqrt x + sqrt (#-3 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #-3 * x & #0 <= #6 + x"; +> val ttt = check_elementwise thy consts (bdv,pred); +> (cterm_of thy) ttt; +val it = "[]" : cterm*) + + +(* 14.1.01: for Tac-dummies in root-equ only: skip str until "("*) +fun split_dummy str = +let fun scan s' [] = (implode s', "") + | scan s' (s::ss) = if s=" " then (implode s', implode ss) + else scan (s'@[s]) ss; +in ((scan []) o explode) str end; +(* split_dummy "subproblem_equation_dummy (x=-#5//#12)"; +val it = ("subproblem_equation_dummy","(x=-#5//#12)") : string * string +> split_dummy "x=-#5//#12"; +val it = ("x=-#5//#12","") : string * string*) + + + + +(*.applicability of a tacic wrt. a calc-state (ptree,pos'). + additionally used by next_tac in the script-interpreter for sequence-tacs. + tests for applicability are so expensive, that results (rewrites!) + are kept in the return-value of 'type tac_'. +.*) +fun applicable_in (_:pos') _ (Init_Proof (ct', spec)) = + Appl (Init_Proof' (ct', spec)) + + | applicable_in (p,p_) pt Model_Problem = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str Model_Problem)^ + " not for pos "^(pos'2str (p,p_))) + else let val (PblObj{origin=(_,(_,pI',_),_),...}) = get_obj I pt p + val {ppc,...} = get_pbt pI' + val pbl = init_pbl ppc + in Appl (Model_Problem' (pI', pbl, [])) end +(* val Refine_Tacitly pI = m; + *) + | applicable_in (p,p_) pt (Refine_Tacitly pI) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Refine_Tacitly pI))^ + " not for pos "^(pos'2str (p,p_))) + else (* val Refine_Tacitly pI = m; + *) + let val (PblObj {origin = (oris, (dI',_,_),_), ...}) = get_obj I pt p; + val opt = refine_ori oris pI; + in case opt of + SOME pblID => + Appl (Refine_Tacitly' (pI, pblID, + e_domID, e_metID, [](*filled in specify*))) + | NONE => Notappl ((tac2str (Refine_Tacitly pI))^ + " not applicable") end +(* val (p,p_) = ip; + val Refine_Problem pI = m; + *) + | applicable_in (p,p_) pt (Refine_Problem pI) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Refine_Problem pI))^ + " not for pos "^(pos'2str (p,p_))) + else + let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_), + probl=itms, ...}) = get_obj I pt p; + val thy = if dI' = e_domID then dI else dI'; + val rfopt = refine_pbl (assoc_thy thy) pI itms; + in case rfopt of + NONE => Notappl ((tac2str (Refine_Problem pI))^" not applicable") + | SOME (rf as (pI',_)) => +(* val SOME (rf as (pI',_)) = rfopt; + *) + if pI' = pI + then Notappl ((tac2str (Refine_Problem pI))^" not applicable") + else Appl (Refine_Problem' rf) + end + + (*the specify-tacs have cterm' instead term: + parse+error here!!!: see appl_add*) + | applicable_in (p,p_) pt (Add_Given ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Add_Given ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Add_Given' (ct', [(*filled in specify_additem*)])) + (*Add_.. should reject (dsc //) (see fmz=[] in sqrt*) + + | applicable_in (p,p_) pt (Del_Given ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Del_Given ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Del_Given' ct') + + | applicable_in (p,p_) pt (Add_Find ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Add_Find ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Add_Find' (ct', [(*filled in specify_additem*)])) + + | applicable_in (p,p_) pt (Del_Find ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Del_Find ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Del_Find' ct') + + | applicable_in (p,p_) pt (Add_Relation ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Add_Relation ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Add_Relation' (ct', [(*filled in specify_additem*)])) + + | applicable_in (p,p_) pt (Del_Relation ct') = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Del_Relation ct'))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Del_Relation' ct') + + | applicable_in (p,p_) pt (Specify_Theory dI) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Specify_Theory dI))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Specify_Theory' dI) +(* val (p,p_) = p; val Specify_Problem pID = m; + val Specify_Problem pID = m; + *) + | applicable_in (p,p_) pt (Specify_Problem pID) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Specify_Problem pID))^ + " not for pos "^(pos'2str (p,p_))) + else + let val (PblObj {origin=(oris,(dI,pI,_),_),spec=(dI',pI',_), + probl=itms, ...}) = get_obj I pt p; + val thy = assoc_thy (if dI' = e_domID then dI else dI'); + val {ppc,where_,prls,...} = get_pbt pID; + val pbl = if pI'=e_pblID andalso pI=e_pblID + then (false, (init_pbl ppc, [])) + else match_itms_oris thy itms (ppc,where_,prls) oris; + in Appl (Specify_Problem' (pID, pbl)) end +(* val Specify_Method mID = nxt; val (p,p_) = p; + *) + | applicable_in (p,p_) pt (Specify_Method mID) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Specify_Method mID))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Specify_Method' (mID,[(*filled in specify*)], + [(*filled in specify*)])) + + | applicable_in (p,p_) pt (Apply_Method mI) = + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res + then Notappl ((tac2str (Apply_Method mI))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Apply_Method' (mI, NONE, e_istate (*filled in solve*))) + + | applicable_in (p,p_) pt (Check_Postcond pI) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str (Check_Postcond pI))^ + " not for pos "^(pos'2str (p,p_))) + else Appl (Check_Postcond' + (pI,(e_term,[(*asm in solve*)]))) + (* in solve -"- ^^^^^^ gets returnvalue of scr*) + + (*these are always applicable*) + | applicable_in (p,p_) _ (Take str) = Appl (Take' (str2term str)) + | applicable_in (p,p_) _ (Free_Solve) = Appl (Free_Solve') + +(* val m as Rewrite_Inst (subs, thm') = m; + *) + | applicable_in (p,p_) pt (m as Rewrite_Inst (subs, thm')) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val {rew_ord'=ro',erls=erls,...} = + get_met (get_obj g_metID pt pp); + val (f,p) = case p_ of (*p 12.4.00 unnecessary*) + Frm => (get_obj g_form pt p, p) + | Res => ((fst o (get_obj g_result pt)) p, lev_on p) + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in + let val subst = subs2subst thy subs; + val subs' = subst2subs' subst; + in case rewrite_inst_ thy (assoc_rew_ord ro') erls + (*put_asm*)false subst (assoc_thm' thy thm') f of + SOME (f',asm) => Appl ( + Rewrite_Inst' (thy',ro',erls,(*put_asm*)false,subst,thm', + (*term_of o the o (parse (assoc_thy thy'))*) f, + (*(term_of o the o (parse (assoc_thy thy'))*) (f', + (*map (term_of o the o (parse (assoc_thy thy')))*) asm))) + | NONE => Notappl ((fst thm')^" not applicable") end + handle _ => Notappl ("syntax error in "^(subs2str subs)) end + +(* val ((p,p_), pt, m as Rewrite thm') = (p, pt, m); + val ((p,p_), pt, m as Rewrite thm') = (pos, pt, tac); + *) +| applicable_in (p,p_) pt (m as Rewrite thm') = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let val (msg,thy',ro,rls',(*put_asm*)_)= from_pblobj_or_detail_thm thm' p pt; + val thy = assoc_thy thy'; + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + | _ => raise error ("applicable_in Rewrite: call by "^ + (pos'2str (p,p_))); + in if msg = "OK" + then + ((*writeln("### applicable_in rls'= "^rls');*) + (* val SOME (f',asm)=rewrite thy' ro (id_rls rls') put_asm thm' f; + *) + case rewrite_ thy (assoc_rew_ord ro) + rls' false (assoc_thm' thy thm') f of + SOME (f',asm) => Appl ( + Rewrite' (thy',ro,rls',(*put_asm*)false,thm', f, (f', asm))) + | NONE => Notappl ("'"^(fst thm')^"' not applicable") ) + else Notappl msg + end + +| applicable_in (p,p_) pt (m as Rewrite_Asm thm') = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val {rew_ord'=ro',erls=erls,...} = + get_met (get_obj g_metID pt pp); + (*val put_asm = true;*) + val (f,p) = case p_ of (*p 12.4.00 unnecessary*) + Frm => (get_obj g_form pt p, p) + | Res => ((fst o (get_obj g_result pt)) p, lev_on p) + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in case rewrite_ thy (assoc_rew_ord ro') erls + (*put_asm*)false (assoc_thm' thy thm') f of + SOME (f',asm) => Appl ( + Rewrite' (thy',ro',erls,(*put_asm*)false,thm', f, (f', asm))) + | NONE => Notappl ("'"^(fst thm')^"' not applicable") end + + | applicable_in (p,p_) pt (m as Detail_Set_Inst (subs, rls)) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val {rew_ord'=ro',...} = get_met (get_obj g_metID pt pp); + val f = case p_ of Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in + let val subst = subs2subst thy subs + val subs' = subst2subs' subst + in case rewrite_set_inst_ thy false subst (assoc_rls rls) f of + SOME (f',asm) => Appl ( + Detail_Set_Inst' (thy',false,subst,assoc_rls rls, f, (f', asm))) + | NONE => Notappl (rls^" not applicable") end + handle _ => Notappl ("syntax error in "^(subs2str subs)) end + + | applicable_in (p,p_) pt (m as Rewrite_Set_Inst (subs, rls)) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val {rew_ord'=ro',(*asm_rls=asm_rls,*)...} = + get_met (get_obj g_metID pt pp); + val (f,p) = case p_ of (*p 12.4.00 unnecessary*) + Frm => (get_obj g_form pt p, p) + | Res => ((fst o (get_obj g_result pt)) p, lev_on p) + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in + let val subst = subs2subst thy subs; + val subs' = subst2subs' subst; + in case rewrite_set_inst_ thy (*put_asm*)false subst (assoc_rls rls) f of + SOME (f',asm) => Appl ( + Rewrite_Set_Inst' (thy',(*put_asm*)false,subst,assoc_rls rls, f, (f', asm))) + | NONE => Notappl (rls^" not applicable") end + handle _ => Notappl ("syntax error in "^(subs2str subs)) end + + | applicable_in (p,p_) pt (m as Rewrite_Set rls) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val (f,p) = case p_ of (*p 12.4.00 unnecessary*) + Frm => (get_obj g_form pt p, p) + | Res => ((fst o (get_obj g_result pt)) p, lev_on p) + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of + SOME (f',asm) => + ((*writeln("#.# applicable_in Rewrite_Set,2f'= "^f');*) + Appl (Rewrite_Set' (thy',(*put_asm*)false,assoc_rls rls, f, (f', asm))) + ) + | NONE => Notappl (rls^" not applicable") end + + | applicable_in (p,p_) pt (m as Detail_Set rls) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let val pp = par_pblobj pt p + val thy' = (get_obj g_domID pt pp):theory' + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of + SOME (f',asm) => + Appl (Detail_Set' (thy',false,assoc_rls rls, f, (f',asm))) + | NONE => Notappl (rls^" not applicable") end + + + | applicable_in p pt (End_Ruleset) = + raise error ("applicable_in: not impl. for "^ + (tac2str End_Ruleset)) + +(* val ((p,p_), pt, (m as Calculate op_)) = (p, pt, m); + *) +| applicable_in (p,p_) pt (m as Calculate op_) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val (msg,thy',isa_fn) = from_pblobj_or_detail_calc op_ p pt; + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + in if msg = "OK" then + case calculate_ (assoc_thy thy') isa_fn f of + SOME (f', (id, thm)) => + Appl (Calculate' (thy',op_, f, (f', (id, string_of_thmI thm)))) + | NONE => Notappl ("'calculate "^op_^"' not applicable") + else Notappl msg + end + +(*Substitute combines two different kind of "substitution": + (1) subst_atomic: for ?a..?z + (2) Pattern.match: for solving equational systems + (which raises exn for ?a..?z)*) + | applicable_in (p,p_) pt (m as Substitute sube) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else let val pp = par_pblobj pt p + val thy = assoc_thy (get_obj g_domID pt pp) + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp) + val subte = sube2subte sube + val subst = sube2subst thy sube + in if foldl and_ (true, map contains_Var subte) + (*1*) + then let val f' = subst_atomic subst f + in if f = f' then Notappl (sube2str sube^" not applicable") + else Appl (Substitute' (subte, f, f')) + end + (*2*) + else case rewrite_terms_ thy (assoc_rew_ord rew_ord') + erls subte f of + SOME (f', _) => Appl (Substitute' (subte, f, f')) + | NONE => Notappl (sube2str sube^" not applicable") + end +(*-------WN08114 interrupted with error in polyminus.sml "11 = 11" + | applicable_in (p,p_) pt (m as Substitute sube) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else let val pp = par_pblobj pt p + val thy = assoc_thy (get_obj g_domID pt pp) + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp) + val subte = sube2subte sube + in case rewrite_terms_ thy (assoc_rew_ord rew_ord') erls subte f of + SOME (f', _) => Appl (Substitute' (subte, f, f')) + | NONE => Notappl (sube2str sube^" not applicable") + end +------------------*) + + | applicable_in p pt (Apply_Assumption cts') = + (raise error ("applicable_in: not impl. for "^ + (tac2str (Apply_Assumption cts')))) + + (*'logical' applicability wrt. script in locate: Inconsistent?*) + | applicable_in (p,p_) pt (m as Take ct') = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let val thy' = get_obj g_domID pt (par_pblobj pt p); + in (case parse (assoc_thy thy') ct' of + SOME ct => Appl (Take' (term_of ct)) + | NONE => Notappl ("syntax error in "^ct')) + end + + | applicable_in p pt (Take_Inst ct') = + raise error ("applicable_in: not impl. for "^ + (tac2str (Take_Inst ct'))) + + | applicable_in p pt (Group (con, ints)) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Group (con, ints)))) + + | applicable_in (p,p_) pt (m as Subproblem (domID, pblID)) = + if member op = [Pbl,Met] p_ + then (*maybe Apply_Method has already been done*) + case get_obj g_env pt p of + SOME is => Appl (Subproblem' ((domID, pblID, e_metID), [], + e_term, [], subpbl domID pblID)) + | NONE => Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else (*somewhere later in the script*) + Appl (Subproblem' ((domID, pblID, e_metID), [], + e_term, [], subpbl domID pblID)) + + | applicable_in p pt (End_Subproblem) = + raise error ("applicable_in: not impl. for "^ + (tac2str (End_Subproblem))) + + | applicable_in p pt (CAScmd ct') = + raise error ("applicable_in: not impl. for "^ + (tac2str (CAScmd ct'))) + + | applicable_in p pt (Split_And) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Split_And))) + | applicable_in p pt (Conclude_And) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Conclude_And))) + | applicable_in p pt (Split_Or) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Split_Or))) + | applicable_in p pt (Conclude_Or) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Conclude_Or))) + + | applicable_in (p,p_) pt (Begin_Trans) = + let + val (f,p) = case p_ of (*p 12.4.00 unnecessary*) + (*_____ implizit Take in gen*) + Frm => (get_obj g_form pt p, (lev_on o lev_dn) p) + | Res => ((fst o (get_obj g_result pt)) p, (lev_on o lev_dn o lev_on) p) + | _ => raise error ("applicable_in: call by "^ + (pos'2str (p,p_))); + val thy' = get_obj g_domID pt (par_pblobj pt p); + in (Appl (Begin_Trans' f)) + handle _ => raise error ("applicable_in: Begin_Trans finds \ + \syntaxerror in '"^(term2str f)^"'") end + + (*TODO: check parent branches*) + | applicable_in (p,p_) pt (End_Trans) = + let val thy' = get_obj g_domID pt (par_pblobj pt p); + in if p_ = Res + then Appl (End_Trans' (get_obj g_result pt p)) + else Notappl "'End_Trans' is not applicable at \ + \the beginning of a transitive sequence" + (*TODO: check parent branches*) + end + + | applicable_in p pt (Begin_Sequ) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Begin_Sequ))) + | applicable_in p pt (End_Sequ) = + raise error ("applicable_in: not impl. for "^ + (tac2str (End_Sequ))) + | applicable_in p pt (Split_Intersect) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Split_Intersect))) + | applicable_in p pt (End_Intersect) = + raise error ("applicable_in: not impl. for "^ + (tac2str (End_Intersect))) +(* val Appl (Check_elementwse'(t1,"Assumptions",t2)) = it; + val (vvv,ppp) = vp; + + val Check_elementwise pred = m; + + val ((p,p_), Check_elementwise pred) = (p, m); + *) + | applicable_in (p,p_) pt (m as Check_elementwise pred) = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy' + val metID = (get_obj g_metID pt pp) + val {crls,...} = get_met metID + (*val _=writeln("### applicable_in Check_elementwise: crls= "^crls) + val _=writeln("### applicable_in Check_elementwise: pred= "^pred)*) + (*val erl = the (assoc'(!ruleset',crls))*) + val (f,asm) = case p_ of + Frm => (get_obj g_form pt p , []) + | Res => get_obj g_result pt p; + (*val _= writeln("### applicable_in Check_elementwise: f= "^f);*) + val vp = mk_set thy pt p f ((term_of o the o (parse thy)) pred); + (*val (v,p)=vp;val _=writeln("### applicable_in Check_elementwise: vp= "^ + pair2str(term2str v,term2str p))*) + in case f of + Const ("List.list.Cons",_) $ _ $ _ => + Appl (Check_elementwise' + (f, pred, + ((*writeln("### applicable_in Check_elementwise: --> "^ + (res2str (check_elementwise thy crls f vp)));*) + check_elementwise thy crls f vp))) + | Const ("Tools.UniversalList",_) => + Appl (Check_elementwise' (f, pred, (f,asm))) + | Const ("List.list.Nil",_) => + (*Notappl "not applicable to empty list" 3.6.03*) + Appl (Check_elementwise' (f, pred, (f,asm(*[] 11.6.03???*)))) + | _ => Notappl ("not applicable: "^(term2str f)^" should be constants") + end + + | applicable_in (p,p_) pt Or_to_List = + if member op = [Pbl,Met] p_ + then Notappl ((tac2str Or_to_List)^" not for pos "^(pos'2str (p,p_))) + else + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p; + in (let val ls = or2list f + in Appl (Or_to_List' (f, ls)) end) + handle _ => Notappl ("'Or_to_List' not applicable to "^(term2str f)) + end + + | applicable_in p pt (Collect_Trues) = + raise error ("applicable_in: not impl. for "^ + (tac2str (Collect_Trues))) + + | applicable_in p pt (Empty_Tac) = + Notappl "Empty_Tac is not applicable" + + | applicable_in (p,p_) pt (Tac id) = + let + val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p; + in case id of + "subproblem_equation_dummy" => + if is_expliceq f + then Appl (Tac_ (thy, term2str f, id, + "subproblem_equation_dummy ("^(term2str f)^")")) + else Notappl "applicable only to equations made explicit" + | "solve_equation_dummy" => + let (*val _= writeln("### applicable_in: solve_equation_dummy: f= " + ^f);*) + val (id',f') = split_dummy (term2str f); + (*val _= writeln("### applicable_in: f'= "^f');*) + (*val _= (term_of o the o (parse thy)) f';*) + (*val _= writeln"### applicable_in: solve_equation_dummy";*) + in if id' <> "subproblem_equation_dummy" then Notappl "no subproblem" + else if is_expliceq ((term_of o the o (parse thy)) f') + then Appl (Tac_ (thy, term2str f, id, "[" ^ f' ^ "]")) + else error ("applicable_in: f= " ^ f') end + | _ => Appl (Tac_ (thy, term2str f, id, term2str f)) end + + | applicable_in p pt End_Proof' = Appl End_Proof'' + + | applicable_in _ _ m = + raise error ("applicable_in called for "^(tac2str m)); + +(*WN060614 unused*) +fun tac2tac_ pt p m = + case applicable_in p pt m of + Appl (m') => m' + | Notappl _ => raise error ("tac2mstp': fails with"^ + (tac2str m)); + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/calchead.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/calchead.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,2257 @@ +(* Specify-phase: specifying and modeling a problem or a subproblem. The + most important types are declared in mstools.sml. + author: Walther Neuper + 991122 + (c) due to copyright terms + +use"ME/calchead.sml"; +use"calchead.sml"; +12345678901234567890123456789012345678901234567890123456789012345678901234567890 + 10 20 30 40 50 60 70 80 +*) + +(* TODO interne Funktionen aus sig entfernen *) +signature CALC_HEAD = + sig + datatype additm = Add of SpecifyTools.itm | Err of string + val all_dsc_in : SpecifyTools.itm_ list -> Term.term list + val all_modspec : ptree * pos' -> ptree * pos' + datatype appl = Appl of tac_ | Notappl of string + val appl_add : + theory -> + string -> + SpecifyTools.ori list -> + SpecifyTools.itm list -> + (string * (Term.term * Term.term)) list -> cterm' -> additm + type calcstate + type calcstate' + val chk_vars : term ppc -> string * Term.term list + val chktyp : + theory -> int * term list * term list -> term + val chktyps : + theory -> term list * term list -> term list + val complete_metitms : + SpecifyTools.ori list -> + SpecifyTools.itm list -> + SpecifyTools.itm list -> pat list -> SpecifyTools.itm list + val complete_mod_ : ori list * pat list * pat list * itm list -> + itm list * itm list + val complete_mod : ptree * pos' -> ptree * (pos * pos_) + val complete_spec : ptree * pos' -> ptree * pos' + val cpy_nam : + pat list -> preori list -> pat -> preori + val e_calcstate : calcstate + val e_calcstate' : calcstate' + val eq1 : ''a -> 'b * (''a * 'c) -> bool + val eq3 : + ''a -> Term.term -> 'b * 'c * 'd * ''a * SpecifyTools.itm_ -> bool + val eq4 : ''a -> 'b * ''a list * 'c * 'd * 'e -> bool + val eq5 : + 'a * 'b * 'c * 'd * SpecifyTools.itm_ -> + 'e * 'f * 'g * Term.term * 'h -> bool + val eq_dsc : SpecifyTools.itm * SpecifyTools.itm -> bool + val eq_pos' : ''a * pos_ -> ''a * pos_ -> bool + val f_mout : theory -> mout -> Term.term + val filter_outs : + SpecifyTools.ori list -> + SpecifyTools.itm list -> SpecifyTools.ori list + val filter_pbt : + SpecifyTools.ori list -> + ('a * (Term.term * 'b)) list -> SpecifyTools.ori list + val foldl1 : ('a * 'a -> 'a) -> 'a list -> 'a + val foldr1 : ('a * 'a -> 'a) -> 'a list -> 'a + val form : 'a -> ptree -> (string * ('a * pos_) * Term.term) list + val formres : 'a -> ptree -> (string * ('a * pos_) * Term.term) list + val gen_ins' : ('a * 'a -> bool) -> 'a * 'a list -> 'a list + val get_formress : + (string * (pos * pos_) * Term.term) list list -> + pos -> ptree list -> (string * (pos * pos_) * Term.term) list + val get_forms : + (string * (pos * pos_) * Term.term) list list -> + posel list -> ptree list -> (string * (pos * pos_) * Term.term) list + val get_interval : pos' -> pos' -> int -> ptree -> (pos' * term) list + val get_ocalhd : ptree * pos' -> ocalhd + val get_spec_form : tac_ -> pos' -> ptree -> mout + val geti_ct : + theory -> + SpecifyTools.ori -> SpecifyTools.itm -> string * cterm' + val getr_ct : theory -> SpecifyTools.ori -> string * cterm' + val has_list_type : Term.term -> bool + val header : pos_ -> pblID -> metID -> pblmet + val insert_ppc : + theory -> + int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ -> + SpecifyTools.itm list -> SpecifyTools.itm list + val insert_ppc' : + SpecifyTools.itm -> SpecifyTools.itm list -> SpecifyTools.itm list + val is_complete_mod : ptree * pos' -> bool + val is_complete_mod_ : SpecifyTools.itm list -> bool + val is_complete_modspec : ptree * pos' -> bool + val is_complete_spec : ptree * pos' -> bool + val is_copy_named : 'a * ('b * Term.term) -> bool + val is_copy_named_idstr : string -> bool + val is_error : SpecifyTools.itm_ -> bool + val is_field_correct : ''a -> ''b -> (''a * ''b list) list -> bool + val is_known : + theory -> + string -> + SpecifyTools.ori list -> + Term.term -> string * SpecifyTools.ori * Term.term list + val is_list_type : Term.typ -> bool + val is_notyet_input : + theory -> + SpecifyTools.itm list -> + Term.term list -> + SpecifyTools.ori -> + ('a * (Term.term * Term.term)) list -> string * SpecifyTools.itm + val is_parsed : SpecifyTools.itm_ -> bool + val is_untouched : SpecifyTools.itm -> bool + val matc : + theory -> + pat list -> + Term.term list -> + (int list * string * Term.term * Term.term list) list -> + (int list * string * Term.term * Term.term list) list + val match_ags : + theory -> pat list -> Term.term list -> SpecifyTools.ori list + val maxl : int list -> int + val match_ags_msg : string list -> Term.term -> Term.term list -> unit + val memI : ''a list -> ''a -> bool + val mk_additem : string -> cterm' -> tac + val mk_delete : theory -> string -> SpecifyTools.itm_ -> tac + val mtc : + theory -> pat -> Term.term -> SpecifyTools.preori option + val nxt_add : + theory -> + SpecifyTools.ori list -> + (string * (Term.term * 'a)) list -> + SpecifyTools.itm list -> (string * cterm') option + val nxt_model_pbl : tac_ -> ptree * (int list * pos_) -> tac_ + val nxt_spec : + pos_ -> + bool -> + SpecifyTools.ori list -> + spec -> + SpecifyTools.itm list * SpecifyTools.itm list -> + (string * (Term.term * 'a)) list * (string * (Term.term * 'b)) list -> + spec -> pos_ * tac + val nxt_specif : tac -> ptree * (int list * pos_) -> calcstate' + val nxt_specif_additem : + string -> cterm' -> ptree * (int list * pos_) -> calcstate' + val nxt_specify_init_calc : fmz -> calcstate + val ocalhd_complete : + SpecifyTools.itm list -> + (bool * Term.term) list -> domID * pblID * metID -> bool + val ori2Coritm : + pat list -> ori -> itm + val ori_2itm : + 'a -> + SpecifyTools.itm_ -> + Term.term -> Term.term list -> SpecifyTools.ori -> SpecifyTools.itm + val overwrite_ppc : + theory -> + int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ -> + SpecifyTools.itm list -> + (int * SpecifyTools.vats * bool * string * SpecifyTools.itm_) list + val parse_ok : SpecifyTools.itm_ list -> bool + val posform2str : pos' * ptform -> string + val posforms2str : (pos' * ptform) list -> string + val posterms2str : (pos' * term) list -> string (*tests only*) + val ppc135list : 'a SpecifyTools.ppc -> 'a list + val ppc2list : 'a SpecifyTools.ppc -> 'a list + val pt_extract : + ptree * (int list * pos_) -> + ptform * tac option * Term.term list + val pt_form : ppobj -> ptform + val pt_model : ppobj -> pos_ -> ptform + val reset_calchead : ptree * pos' -> ptree * pos' + val seek_oridts : + theory -> + string -> + Term.term * Term.term list -> + (int * SpecifyTools.vats * string * Term.term * Term.term list) list + -> string * SpecifyTools.ori * Term.term list + val seek_orits : + theory -> + string -> + Term.term list -> + (int * SpecifyTools.vats * string * Term.term * Term.term list) list + -> string * SpecifyTools.ori * Term.term list + val seek_ppc : + int -> SpecifyTools.itm list -> SpecifyTools.itm option + val show_pt : ptree -> unit + val some_spec : spec -> spec -> spec + val specify : + tac_ -> + pos' -> + cid -> + ptree -> + (posel list * pos_) * ((posel list * pos_) * istate) * mout * tac * + safe * ptree + val specify_additem : + string -> + cterm' * 'a -> + int list * pos_ -> + 'b -> + ptree -> + (pos * pos_) * ((pos * pos_) * istate) * mout * tac * safe * ptree + val tag_form : theory -> term * term -> term + val test_types : theory -> Term.term * Term.term list -> string + val typeless : Term.term -> Term.term + val unbound_ppc : term SpecifyTools.ppc -> Term.term list + val vals_of_oris : SpecifyTools.ori list -> Term.term list + val variants_in : Term.term list -> int + val vars_of_pbl_ : ('a * ('b * Term.term)) list -> Term.term list + val vars_of_pbl_' : ('a * ('b * Term.term)) list -> Term.term list + end + + + + + +(*---------------------------------------------------------------------*) +structure CalcHead (**): CALC_HEAD(**) = + +struct +(*---------------------------------------------------------------------*) + +(* datatypes *) + +(*.the state wich is stored after each step of calculation; it contains + the calc-state and a list of [tac,istate](="tacis") to be applied. + the last_elem tacis is the first to apply to the calc-state and + the (only) one shown to the front-end as the 'proposed tac'. + the calc-state resulting from the application of tacis is not stored, + because the tacis hold enought information for efficiently rebuilding + this state just by "fun generate ".*) +type calcstate = + (ptree * pos') * (*the calc-state to which the tacis could be applied*) + (taci list); (*ev. several (hidden) steps; + in REVERSE order: first tac_ to apply is last_elem*) +val e_calcstate = ((EmptyPtree, e_pos'), [e_taci]):calcstate; + +(*the state used during one calculation within the mathengine; it contains + a list of [tac,istate](="tacis") which generated the the calc-state; + while this state's tacis are extended by each (internal) step, + the calc-state is used for creating new nodes in the calc-tree + (eg. applicable_in requires several particular nodes of the calc-tree) + and then replaced by the the newly created; + on leave of the mathengine the resuing calc-state is dropped anyway, + because the tacis hold enought information for efficiently rebuilding + this state just by "fun generate ".*) +type calcstate' = + taci list * (*cas. several (hidden) steps; + in REVERSE order: first tac_ to apply is last_elem*) + pos' list * (*a "continuous" sequence of pos', + deleted by application of taci list*) + (ptree * pos'); (*the calc-state resulting from the application of tacis*) +val e_calcstate' = ([e_taci], [e_pos'], (EmptyPtree, e_pos')):calcstate'; + +(*FIXXXME.WN020430 intermediate hack for fun ass_up*) +fun f_mout thy (Form' (FormKF (_,_,_,_,f))) = (term_of o the o (parse thy)) f + | f_mout thy _ = raise error "f_mout: not called with formula"; + + +(*.is the calchead complete ?.*) +fun ocalhd_complete (its: itm list) (pre: (bool * term) list) (dI,pI,mI) = + foldl and_ (true, map #3 its) andalso + foldl and_ (true, map #1 pre) andalso + dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID; + + +(* make a term 'typeless' for comparing with another 'typeless' term; + 'type-less' usually is illtyped *) +fun typeless (Const(s,_)) = (Const(s,e_type)) + | typeless (Free(s,_)) = (Free(s,e_type)) + | typeless (Var(n,_)) = (Var(n,e_type)) + | typeless (Bound i) = (Bound i) + | typeless (Abs(s,_,t)) = Abs(s,e_type, typeless t) + | typeless (t1 $ t2) = (typeless t1) $ (typeless t2); +(* +> val (SOME ct) = parse thy "max_relation (A=#2*a*b - a^^^#2)"; +> val (_,t1) = split_dsc_t hs (term_of ct); +> val (SOME ct) = parse thy "A=#2*a*b - a^^^#2"; +> val (_,t2) = split_dsc_t hs (term_of ct); +> typeless t1 = typeless t2; +val it = true : bool +*) + + + +(*.to an input (d,ts) find the according ori and insert the ts.*) +(*WN.11.03: + dont take first inter<>[]*) +fun seek_oridts thy sel (d,ts) [] = + ("'"^(Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))^ + "' not found (typed)", (0,[],sel,d,ts):ori, []) + (* val (id,vat,sel',d',ts')::oris = ori; + val (id,vat,sel',d',ts') = ori; + *) + | seek_oridts thy sel (d,ts) ((id,vat,sel',d',ts')::(oris:ori list)) = + if sel = sel' andalso d=d' andalso (inter op = ts ts') <> [] + then if sel = sel' + then ("", + (id,vat,sel,d, inter op = ts ts'):ori, + ts') + else ((Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts))) + ^ " not for " ^ sel, + e_ori_, + []) + else seek_oridts thy sel (d,ts) oris; + +(*.to an input (_,ts) find the according ori and insert the ts.*) +fun seek_orits thy sel ts [] = + ("'"^ + (strs2str (map (Syntax.string_of_term (thy2ctxt thy)) ts))^ + "' not found (typed)", e_ori_, []) + | seek_orits thy sel ts ((id,vat,sel',d,ts')::(oris:ori list)) = + if sel = sel' andalso (inter op = ts ts') <> [] + then if sel = sel' + then ("", + (id,vat,sel,d, inter op = ts ts'):ori, + ts') + else (((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts) + ^ " not for "^sel, + e_ori_, + []) + else seek_orits thy sel ts oris; +(* false +> val ((id,vat,sel',d,ts')::(ori':ori)) = ori; +> seek_orits thy sel ts [(id,vat,sel',d,ts')]; +uncaught exception TYPE +> seek_orits thy sel ts []; +uncaught exception TYPE +*) + +(*find_first item with #1 equal to id*) +fun seek_ppc id [] = NONE + | seek_ppc id (p::(ppc:itm list)) = + if id = #1 p then SOME p else seek_ppc id ppc; + + + +(*---------------------------------------------(3) nach ptyps.sml 23.3.02*) + + +datatype appl = Appl of tac_ | Notappl of string; + +fun ppc2list ({Given=gis,Where=whs,Find=fis, + With=wis,Relate=res}: 'a ppc) = + gis @ whs @ fis @ wis @ res; +fun ppc135list ({Given=gis,Find=fis,Relate=res,...}: 'a ppc) = + gis @ fis @ res; + + + + +(* get the number of variants in a problem in 'original', + assumes equal descriptions in immediate sequence *) +fun variants_in ts = + let fun eq(x,y) = head_of x = head_of y; + fun cnt eq [] y n = ([n],[]) + | cnt eq (x::xs) y n = if eq(x,y) then cnt eq xs y (n+1) + else ([n], x::xs); + fun coll eq xs [] = xs + | coll eq xs (y::ys) = + let val (n,ys') = cnt eq (y::ys) y 0; + in if ys' = [] then xs @ n else coll eq (xs @ n) ys' end; + val vts = subtract op = [1] (distinct (coll eq [] ts)); + in case vts of [] => 1 | [n] => n + | _ => error "different variants in formalization" end; +(* +> cnt (op=) [2,2,2,4,5,5,5,5,5] 2 0; +val it = ([3],[4,5,5,5,5,5]) : int list * int list +> coll (op=) [] [1,2,2,2,4,5,5,5,5,5]; +val it = [1,3,1,5] : int list +*) + +fun is_list_type (Type("List.list",_)) = true + | is_list_type _ = false; +(* fun destr (Type(str,sort)) = (str,sort); +> val (SOME ct) = parse thy "lll::real list"; +> val ty = (#T o rep_cterm) ct; +> is_list_type ty; +val it = true : bool +> destr ty; +val it = ("List.list",["RealDef.real"]) : string * typ list +> atomty ((#t o rep_cterm) ct); +*** ------------- +*** Free ( lll, real list) +val it = () : unit + +> val (SOME ct) = parse thy "[lll::real]"; +> val ty = (#T o rep_cterm) ct; +> is_list_type ty; +val it = true : bool +> destr ty; +val it = ("List.list",["'a"]) : string * typ list +> atomty ((#t o rep_cterm) ct); +*** ------------- +*** Const ( List.list.Cons, [real, real list] => real list) +*** Free ( lll, real) +*** Const ( List.list.Nil, real list) + +> val (SOME ct) = parse thy "lll"; +> val ty = (#T o rep_cterm) ct; +> is_list_type ty; +val it = false : bool *) + + +fun has_list_type (Free(_,T)) = is_list_type T + | has_list_type _ = false; +(* +> val (SOME ct) = parse thy "lll::real list"; +> has_list_type (term_of ct); +val it = true : bool +> val (SOME ct) = parse thy "[lll::real]"; +> has_list_type (term_of ct); +val it = false : bool *) + +fun is_parsed (Syn _) = false + | is_parsed _ = true; +fun parse_ok its = foldl and_ (true, map is_parsed its); + +fun all_dsc_in itm_s = + let + fun d_in (Cor ((d,_),_)) = [d] + | d_in (Syn c) = [] + | d_in (Typ c) = [] + | d_in (Inc ((d,_),_)) = [d] + | d_in (Sup (d,_)) = [d] + | d_in (Mis (d,_)) = [d]; + in (flat o (map d_in)) itm_s end; + +(* 30.1.00 --- +fun is_Syn (Syn _) = true + | is_Syn (Typ _) = true + | is_Syn _ = false; + --- *) +fun is_error (Cor (_,ts)) = false + | is_error (Sup (_,ts)) = false + | is_error (Inc (_,ts)) = false + | is_error (Mis (_,ts)) = false + | is_error _ = true; + +(* 30.1.00 --- +fun ct_in (Syn (c)) = c + | ct_in (Typ (c)) = c + | ct_in _ = raise error "ct_in called for Cor .. Sup"; + --- *) + +(*#############################################################*) +(*#############################################################*) +(* vvv--- aus nnewcode.sml am 30.1.00 ---vvv *) + + +(* testdaten besorgen: + use"test-coil-kernel.sml"; + val (PblObj{origin=(oris,_,_),meth={ppc=itms,...},...}) = + get_obj I pt p; + *) + +(* given oris, ppc, + variant V: oris union ppc => int, id ID: oris union ppc => int + + ppc is_complete == + EX vt:V. ALL r:oris --> EX i:ppc. ID r = ID i & complete i + + and + @vt = max sum(i : ppc) V i +*) + + + +(* +> ((vts_cnt (vts_in itms))) itms; + + + +---^^--test 10.3. +> val vts = vts_in itms; +val vts = [1,2,3] : int list +> val nvts = vts_cnt vts itms; +val nvts = [(1,6),(2,5),(3,7)] : (int * int) list +> val mx = max2 nvts; +val mx = (3,7) : int * int +> val v = max_vt itms; +val v = 3 : int +-------------------------- +> +*) + +(*.get the first term in ts from ori.*) +(* val (_,_,fd,d,ts) = hd miss; + *) +fun getr_ct thy ((_,_,fd,d,ts):ori) = + (fd, ((Syntax.string_of_term (thy2ctxt thy)) o + (comp_dts thy)) (d,[hd ts]):cterm'); +(* val t = comp_dts thy (d,[hd ts]); + *) + +(* get a term from ori, notyet input in itm *) +fun geti_ct thy ((_,_,_,d,ts):ori) ((_,_,_,fd,itm_):itm) = + (fd, ((Syntax.string_of_term (thy2ctxt thy)) o (comp_dts thy)) + (d, subtract op = (ts_in itm_) ts):cterm'); +(* test-maximum.sml fmy <> [], Init_Proof ... + val (_,_,_,d,ts) = ori; val (_,_,_,fd,itm_) = hd icl; + val d' $ ts' = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]"; + atomty d; + atomty d'; + atomty (hd ts); + atomty ts'; + cterm_of thy (d $ (hd ts)); + cterm_of thy (d' $ ts'); + + comp_dts thy (d,ts); + *) + + +(* in FE dsc, not dat: this is in itms ...*) +fun is_untouched ((_,_,false,_,Inc((_,[]),_)):itm) = true + | is_untouched _ = false; + + +(* select an item in oris, notyet input in itms + (precondition: in itms are only Cor, Sup, Inc) *) +local infix mem; +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun nxt_add thy ([]:ori list) pbt itms = (*root (only) ori...fmz=[]*) + let + fun test_d d ((i,_,_,_,itm_):itm) = (d = (d_in itm_)) andalso i<>0; + fun is_elem itms (f,(d,t)) = + case find_first (test_d d) itms of + SOME _ => true | NONE => false; + in case filter_out (is_elem itms) pbt of +(* val ((f,(d,_))::itms) = filter_out (is_elem itms) pbt; + *) + (f,(d,_))::itms => + SOME (f:string, ((Syntax.string_of_term (thy2ctxt thy)) o comp_dts thy) (d,[]):cterm') + | _ => NONE end + +(* val (thy,itms) = (assoc_thy (if dI=e_domID then dI' else dI),pbl); + *) + | nxt_add thy oris pbt itms = + let + fun testr_vt v ori = (curry (op mem) v) (#2 (ori:ori)) + andalso (#3 ori) <>"#undef"; + fun testi_vt v itm = (curry (op mem) v) (#2 (itm:itm)); + fun test_id ids r = curry (op mem) (#1 (r:ori)) ids; +(* val itm = hd icl; val (_,_,_,d,ts) = v6; + *) + fun test_subset (itm:itm) ((_,_,_,d,ts):ori) = + (d_in (#5 itm)) = d andalso subset op = (ts_in (#5 itm), ts); + fun false_and_not_Sup((i,v,false,f,Sup _):itm) = false + | false_and_not_Sup (i,v,false,f, _) = true + | false_and_not_Sup _ = false; + + val v = if itms = [] then 1 else max_vt itms; + val vors = if v = 0 then oris else filter (testr_vt v) oris;(*oris..vat*) + val vits = if v = 0 then itms (*because of dsc without dat*) + else filter (testi_vt v) itms; (*itms..vat*) + val icl = filter false_and_not_Sup vits; (* incomplete *) + in if icl = [] + then case filter_out (test_id (map #1 vits)) vors of + [] => NONE + (* val miss = filter_out (test_id (map #1 vits)) vors; + *) + | miss => SOME (getr_ct thy (hd miss)) + else + case find_first (test_subset (hd icl)) vors of + (* val SOME ori = find_first (test_subset (hd icl)) vors; + *) + NONE => raise error "nxt_add: EX itm. not(dat(itm)<=dat(ori))" + | SOME ori => SOME (geti_ct thy ori (hd icl)) + end +end; + + + +fun mk_delete thy "#Given" itm_ = Del_Given (itm_out thy itm_) + | mk_delete thy "#Find" itm_ = Del_Find (itm_out thy itm_) + | mk_delete thy "#Relate" itm_ = Del_Relation(itm_out thy itm_) + | mk_delete thy str _ = + raise error ("mk_delete: called with field '"^str^"'"); +fun mk_additem "#Given" ct = Add_Given ct + | mk_additem "#Find" ct = Add_Find ct + | mk_additem "#Relate"ct = Add_Relation ct + | mk_additem str _ = + raise error ("mk_additem: called with field '"^str^"'"); + + + + + +(* find the next tac in specify (except nxt_model_pbl) + 4.00.: TODO: do not return a pos !!! + (sind from DG comes the _OLD_ writepos)*) +(* +> val (pbl,pbt,mpc) =(pbl',get_pbt cpI,(#ppc o get_met) cmI); +> val (dI,pI,mI) = empty_spec; +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*)) + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec); + +at Init_Proof: +> val met = [];val (pbt,mpc) = (get_pbt pI',(#ppc o get_met) mI'); +> val (dI,pI,mI) = empty_spec; +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*)) + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec); + *) + +(*. determine the next step of specification; + not done here: Refine_Tacitly (otherwise *** unknown method: (..., no_met)) +eg. in rootpbl 'no_met': +args: + preok predicates are _all_ ok, or problem matches completely + oris immediately from formalization + (dI',pI',mI') specification coming from author/parent-problem + (pbl, item lists specified by user + met) -"-, tacitly completed by copy_probl + (dI,pI,mI) specification explicitly done by the user + (pbt, mpc) problem type, guard of method +.*) +(* val (preok,pbl,pbt,mpc)=(pb,pbl',(#ppc o get_pbt) cpI,(#ppc o get_met) cmI); + val (preok,pbl,pbt,mpc)=(pb,pbl',ppc,(#ppc o get_met) cmI); + val (Pbl, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) = + (p_, pb, oris, (dI',pI',mI'), (probl,meth), + (ppc, (#ppc o get_met) cmI), (dI,pI,mI)); + *) +fun nxt_spec Pbl preok (oris:ori list) ((dI',pI',mI'):spec) + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec) = + ((*writeln"### nxt_spec Pbl";*) + if dI'=e_domID andalso dI=e_domID then (Pbl, Specify_Theory dI') + else if pI'=e_pblID andalso pI=e_pblID then (Pbl, Specify_Problem pI') + else case find_first (is_error o #5) (pbl:itm list) of + SOME (_,_,_,fd,itm_) => + (Pbl, mk_delete + (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_) + | NONE => + ((*writeln"### nxt_spec is_error NONE";*) + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI)) + oris pbt pbl of +(* val SOME (fd,ct') = nxt_add (assoc_thy (if dI=e_domID then dI' else dI)) + oris pbt pbl; + *) + SOME (fd,ct') => ((*writeln"### nxt_spec nxt_add SOME";*) + (Pbl, mk_additem fd ct')) + | NONE => (*pbl-items complete*) + if not preok then (Pbl, Refine_Problem pI') + else + if dI = e_domID then (Pbl, Specify_Theory dI') + else if pI = e_pblID then (Pbl, Specify_Problem pI') + else if mI = e_metID then (Pbl, Specify_Method mI') + else + case find_first (is_error o #5) met of + SOME (_,_,_,fd,itm_) => + (Met, mk_delete (assoc_thy dI) fd itm_) + | NONE => + (case nxt_add (assoc_thy dI) oris mpc met of + SOME (fd,ct') => (*30.8.01: pre?!?*) + (Met, mk_additem fd ct') + | NONE => + ((*Solv 3.4.00*)Met, Apply_Method mI)))) +(* val preok=pb; val (pbl, met) = (pbl,met'); + val (pbt,mpc)=((#ppc o get_pbt) cpI,(#ppc o get_met) cmI); + val (Met, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) = + (p_, pb, oris, (dI',pI',mI'), (probl,meth), + (ppc, (#ppc o get_met) cmI), (dI,pI,mI)); + *) + | nxt_spec Met preok oris (dI',pI',mI') (pbl, met) (pbt,mpc) (dI,pI,mI) = + ((*writeln"### nxt_spec Met"; *) + case find_first (is_error o #5) met of + SOME (_,_,_,fd,itm_) => + (Met, mk_delete (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_) + | NONE => + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))oris mpc met of + SOME (fd,ct') => (Met, mk_additem fd ct') + | NONE => + ((*writeln"### nxt_spec Met: nxt_add NONE";*) + if dI = e_domID then (Met, Specify_Theory dI') + else if pI = e_pblID then (Met, Specify_Problem pI') + else if not preok then (Met, Specify_Method mI) + else (Met, Apply_Method mI))); + +(* di_ pI_ mI_ pos_ +val itms = [(1,[1],true,"#Find",Cor(e_term,[e_term])):itm, + (2,[2],true,"#Find",Syn("empty"))]; +*) + + +(* ^^^--- aus nnewcode.sml am 30.1.00 ---^^^ *) +(*#############################################################*) +(*#############################################################*) +(* vvv--- aus nnewcode.sml vor 29.1.00 ---vvv *) + +(*3.3.-- +fun update_itm (cl,d,ts) ((id,vt,_,sl,Cor (_,_)):itm) = + (id,vt,cl,sl,Cor (d,ts)):itm + | update_itm (cl,d,ts) (id,vt,_,sl,Syn (_)) = + raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^ + " not not for Syn (s:cterm')") + | update_itm (cl,d,ts) (id,vt,_,sl,Typ (_)) = + raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^ + " not not for Typ (s:cterm')") + | update_itm (cl,d,ts) (id,vt,_,sl,Fal (_,_)) = + (id,vt,cl,sl,Fal (d,ts)) + | update_itm (cl,d,ts) (id,vt,_,sl,Inc (_,_)) = + (id,vt,cl,sl,Inc (d,ts)) + | update_itm (cl,d,ts) (id,vt,_,sl,Sup (_,_)) = + (id,vt,cl,sl,Sup (d,ts)); +*) + + + + +fun is_field_correct sel d dscpbt = + case assoc (dscpbt, sel) of + NONE => false + | SOME ds => member op = ds d; + +(*. update the itm_ already input, all..from ori .*) +(* val (id,vt,fd,d,ts) = (i,v,f,d,ts\\ts'); + *) +fun ori_2itm thy itm_ pid all ((id,vt,fd,d,ts):ori) = + let + val ts' = union op = (ts_in itm_) ts; + val pval = pbl_ids' thy d ts' + (*WN.9.5.03: FIXXXME [#0, epsilon] + here would upd_penv be called for [#0, epsilon] etc. *) + val complete = if eq_set op = (ts', all) then true else false; + in case itm_ of + (Cor _) => + (if fd = "#undef" then (id,vt,complete,fd,Sup(d,ts')) + else (id,vt,complete,fd,Cor((d,ts'),(pid, pval)))):itm + | (Syn c) => raise error ("ori_2itm wants to overwrite "^c) + | (Typ c) => raise error ("ori_2itm wants to overwrite "^c) + | (Inc _) => if complete + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval))) + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval))) + | (Sup ((*_,_*)d,ts')) => (*4.9.01 lost env*) + (*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts')) + (*else (id,vt,complete,fd,Cor((d,ts'),e))*) +(* 28.1.00: not completely clear ---^^^ etc.*) +(* 4.9.01: Mis just copied---vvv *) + | (Mis _) => if complete + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval))) + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval))) + end; + + +fun eq1 d (_,(d',_)) = (d = d'); +fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_); + + +(* 'all' ts from ori; ts is the input; (ori carries rest of info) + 9.01: this + ori_2itm is _VERY UNCLEAR_ ? overhead ? + pval: value for problem-environment _NOT_ checked for 'inter' -- + -- FIXXME.WN.11.03 the generation of penv has to go to insert_ppc + (as it has been done for input_icalhd+insert_ppc' in 11.03)*) +(*. is_input ori itms <=> + EX itm. (1) ori(field,dsc) = itm(field,dsc) & (2..4) + (2) ori(ts) subset itm(ts) --- Err "already input" + (3) ori(ts) inter itm(ts) = empty --- new: ori(ts) + (4) -"- <> empty --- new: ori(ts) \\ inter .*) +(* val(itms,(i,v,f,d,ts)) = (ppc,ori'); + *) +fun is_notyet_input thy (itms:itm list) all ((i,v,f,d,ts):ori) pbt = + case find_first (eq1 d) pbt of + SOME (_,(_,pid)) =>(* val SOME (_,(_,pid)) = find_first (eq1 d) pbt; + val SOME (_,_,_,_,itm_)=find_first (eq3 f d) itms; + *) + (case find_first (eq3 f d) itms of + SOME (_,_,_,_,itm_) => + let + val ts' = inter op = (ts_in itm_) ts; + in if subset op = (ts, ts') + then (((strs2str' o + map (Syntax.string_of_term (thy2ctxt thy))) ts')^ + " already input", e_itm) (*2*) + else ("", + ori_2itm thy itm_ pid all (i,v,f,d, + subtract op = ts' ts)) (*3,4*) + end + | NONE => ("", ori_2itm thy (Inc ((e_term,[]),(pid,[]))) + pid all (i,v,f,d,ts)) (*1*) + ) + | NONE => ("", ori_2itm thy (Sup (d,ts)) + e_term all (i,v,f,d,ts)); + +fun test_types thy (d,ts) = + let + val s = !show_types; val _ = show_types:= true; + val opt = (try (comp_dts thy)) (d,ts); + val msg = case opt of + SOME _ => "" + | NONE => ((Syntax.string_of_term (thy2ctxt thy) d)^" "^ + ((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts) + ^ " is illtyped"); + val _ = show_types:= s + in msg end; + + + +fun maxl [] = raise error "maxl of []" + | maxl (y::ys) = + let fun mx x [] = x + | mx x (y::ys) = if x < (y:int) then mx y ys else mx x ys + in mx y ys end; + + +(*. is the input term t known in oris ? + give feedback on all(?) strange input; + return _all_ terms already input to this item (e.g. valuesFor a,b) .*) +(*WN.11.03: from lists*) +fun is_known thy sel ori t = +(* val (ori,t)=(oris,term_of ct); + *) + let + val ots = (distinct o flat o (map #5)) (ori:ori list); + val oids = ((map (fst o dest_Free)) o distinct o + flat o (map vars)) ots; + val (d,ts(*,pval*)) = split_dts thy t; + val ids = map (fst o dest_Free) + ((distinct o (flat o (map vars))) ts); + in if (subtract op = oids ids) <> [] + then (("identifiers "^(strs2str' (subtract op = oids ids))^ + " not in example"), e_ori_, []) + else + if d = e_term + then + if not (subset op = (map typeless ts, map typeless ots)) + then (("terms '"^ + ((strs2str' o (map (Syntax.string_of_term + (thy2ctxt thy)))) ts)^ + "' not in example (typeless)"), e_ori_, []) + else (case seek_orits thy sel ts ori of + ("", ori_ as (_,_,_,d,ts), all) => + (case test_types thy (d,ts) of + "" => ("", ori_, all) + | msg => (msg, e_ori_, [])) + | (msg,_,_) => (msg, e_ori_, [])) + else + if member op = (map #4 ori) d + then seek_oridts thy sel (d,ts) ori + else ((Syntax.string_of_term (thy2ctxt thy) d)^ + (*" not in example", e_ori_, []) ///11.11.03*) + " not in example", (0,[],sel,d,ts), []) + end; + + +(*. for return-value of appl_add .*) +datatype additm = + Add of itm + | Err of string; (*error-message*) + + +(*. add an item; check wrt. oris and pbt .*) + +(* in contrary to oris<>[] below, this part handles user-input + extremely acceptive, i.e. accept input instead error-msg *) +fun appl_add thy sel ([]:ori list) ppc pbt ct' = +(* val (ppc,pbt,ct',env) = (pbl, (#ppc o get_pbt) cpI, ct, []:envv); + !!!! 28.8.01: env tested _minimally_ !!! + *) + let + val i = 1 + (if ppc=[] then 0 else maxl (map #1 ppc)); + in case parse thy ct' of (*should be done in applicable_in 4.00.FIXME*) + NONE => Add (i,[],false,sel,Syn ct') +(* val (SOME ct) = parse thy ct'; + *) + | SOME ct => + let + val (d,ts(*,pval*)) = split_dts thy (term_of ct); + in if d = e_term + then Add (i,[],false,sel,Mis (dsc_unknown,hd ts(*24.3.02*))) + + else + (case find_first (eq1 d) pbt of + NONE => Add (i,[],true,sel,Sup ((d,ts))) + | SOME (f,(_,id)) => +(* val SOME (f,(_,id)) = find_first (eq1 d) pbt; + *) + let + fun eq2 d ((i,_,_,_,itm_):itm) = + (d = (d_in itm_)) andalso i<>0; + in case find_first (eq2 d) ppc of + NONE => Add (i,[],true,f, Cor ((d,ts), (id, (*pval*) + pbl_ids' thy d ts))) + | SOME (i',_,_,_,itm_) => +(* val SOME (i',_,_,_,itm_) = find_first (eq2 d) ppc; + val NONE = find_first (eq2 d) ppc; + *) + if is_list_dsc d + then let val ts = union op = ts (ts_in itm_) + in Add (if ts_in itm_ = [] then i else i', + [],true,f,Cor ((d, ts), (id, (*pval*) + pbl_ids' thy d ts))) + end + else Add (i',[],true,f,Cor ((d,ts),(id, (*pval*) + pbl_ids' thy d ts))) + end + ) + end + end +(*. add ct to ppc .*) +(*FIXXME: accept items as Sup, Syn here, too (like appl_add..oris=[] above)*) +(* val (ppc,pbt) = (pbl, ppc); + val (ppc,pbt) = (met, (#ppc o get_met) cmI); + + val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI); + *) + | appl_add thy sel oris ppc pbt(*only for upd_envv*) ct = + let + val ctopt = parse thy ct; + in case ctopt of + NONE => Err ("syntax error in "^ct) + | SOME ct =>(* val SOME ct = ctopt; + val (msg,ori',all) = is_known thy sel oris (term_of ct); + val (msg,itm) = is_notyet_input thy ppc all ori' pbt; + *) + (case is_known thy sel oris (term_of ct) of + ("",ori'(*ts='ct'*), all) => + (case is_notyet_input thy ppc all ori' pbt of + ("",itm) => Add itm + | (msg,_) => Err msg) + | (msg,_,_) => Err msg) + end; +(* +> val (msg,itm) = is_notyet_input thy ppc all ori'; +val itm = (12,[3],false,"#Relate",Cor (Const #,[#,#])) : itm +> val itm_ = #5 itm; +> val ts = ts_in itm_; +> map (atomty) ts; +*) + +(*---------------------------------------------(4) nach ptyps.sml 23.3.02*) + + +(** make oris from args of the stac SubProblem and from pbt **) + +(*.can this formal argument (of a model-pattern) be omitted in the arg-list + of a SubProblem ? see ME/ptyps.sml 'type met '.*) +fun is_copy_named_idstr str = + case (rev o explode) str of + "_"::_::"_"::_ => true + | _ => false; +(*> is_copy_named_idstr "v_i_"; +val it = true : bool + > is_copy_named_idstr "e_"; +val it = false : bool + > is_copy_named_idstr "L___"; +val it = true : bool +*) +(*.should this formal argument (of a model-pattern) create a new identifier?.*) +fun is_copy_named_generating_idstr str = + if is_copy_named_idstr str + then case (rev o explode) str of + "_"::"_"::"_"::_ => false + | _ => true + else false; +(*> is_copy_named_generating_idstr "v_i_"; +val it = true : bool + > is_copy_named_generating_idstr "L___"; +val it = false : bool +*) + +(*.can this formal argument (of a model-pattern) be omitted in the arg-list + of a SubProblem ? see ME/ptyps.sml 'type met '.*) +fun is_copy_named (_,(_,t)) = (is_copy_named_idstr o free2str) t; +(*.should this formal argument (of a model-pattern) create a new identifier?.*) +fun is_copy_named_generating (_,(_,t)) = + (is_copy_named_generating_idstr o free2str) t; + + +(*.split type-wrapper from scr-arg and build part of an ori; + an type-error is reported immediately, raises an exn, + subsequent handling of exn provides 2nd part of error message.*) +(*fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = WN100820 made cterm to term + (* val (thy, (str, (dsc, _)), (ty $ var)) = + (thy, p, a); + *) + (cterm_of thy (dsc $ var);(*type check*) + SOME ((([1], str, dsc, (*[var]*) + split_dts' (dsc, var))): preori)(*:ori without leading #*)) + handle e as TYPE _ => + (writeln (dashs 70^"\n" + ^"*** ERROR while creating the items for the model of the ->problem\n" + ^"*** from the ->stac with ->typeconstructor in arglist:\n" + ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n" + ^"*** description: "^(term_detail2str dsc) + ^"*** value: "^(term_detail2str var) + ^"*** typeconstructor in script: "^(term_detail2str ty) + ^"*** checked by theory: "^(theory2str thy)^"\n" + ^"*** "^dots 66); + print_exn e; (*raises exn again*) + NONE);*) +fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = + (* val (thy, (str, (dsc, _)), (ty $ var)) = + (thy, p, a); + *) + (cterm_of thy (dsc $ var);(*type check*) + SOME ((([1], str, dsc, (*[var]*) + split_dts' (dsc, var))): preori)(*:ori without leading #*)) + handle e as TYPE _ => + (writeln (dashs 70^"\n" + ^"*** ERROR while creating the items for the model of the ->problem\n" + ^"*** from the ->stac with ->typeconstructor in arglist:\n" + ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n" + ^"*** description: "^(term_detail2str dsc) + ^"*** value: "^(term_detail2str var) + ^"*** typeconstructor in script: "^(term_detail2str ty) + ^"*** checked by theory: "^(theory2str thy)^"\n" + ^"*** "^dots 66); + (*WN100820 postponed: print_exn e; raises exn again*) + NONE); +(*> val pbt = (#ppc o get_pbt) ["univariate","equation"]; +> val Const ("Script.SubProblem",_) $ + (Const ("Pair",_) $ Free (thy', _) $ + (Const ("Pair",_) $ pblID' $ metID')) $ ags = + str2term"(SubProblem (SqRoot_,[univariate,equation],\ + \[SqRoot_,solve_linear]) [bool_ (x+1- 2=0), real_ x])::bool list"; +> val ags = isalist2list ags; +> mtc thy (hd pbt) (hd ags); +val it = SOME ([1],"#Given",Const (#,#),[# $ #]) *) + +(*.match each pat of the model-pattern with an actual argument; + precondition: copy-named vars are filtered out.*) +fun matc thy ([]:pat list) _ (oris:preori list) = oris + | matc thy pbt [] _ = + (writeln (dashs 70); + raise error ("actual arg(s) missing for '"^pats2str pbt + ^"' i.e. should be 'copy-named' by '*_._'")) + | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris = + (* val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) = + (thy, pbt', ags, []); + (*recursion..*) + val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) = + (thy, pbt, ags, (oris @ [ori])); + *) + (*del?..*)if (is_copy_named_idstr o free2str) t then oris + else(*..del?*) let val opt = mtc thy p a; + in case opt of + (* val SOME ori = mtc thy p a; + *) + SOME ori => matc thy pbt ags (oris @ [ori]) + | NONE => [](*WN050903 skipped by exn handled in match_ags*) + end; +(* run subp-rooteq.sml until Init_Proof before ... +> val Nd (PblObj {origin=(oris,_,_),...},_) = pt;(*from test/subp-rooteq.sml*) +> fun xxxfortest (_,a,b,c,d) = (a,b,c,d);val oris = map xxxfortest oris; + + other vars as in mtc .. +> matc thy (drop_last pbt) ags []; +val it = ([[1],"#Given",Const #,[#]),(0,[#],"#Given",Const #,[#])],2)*) + + +(*WN051014 outcommented with redesign copy-named (for omitting '#Find' + in SubProblem); + kept as initial idea for generating x_1, x_2, ... for equations*) +fun cpy_nam (pbt:pat list) (oris:preori list) (p as (field,(dsc,t)):pat) = +(* val ((pbt:pat list), (oris:preori list), ((field,(dsc,t)):pat)) = + (pbt', oris', hd (*!!!!!*) cy); + *) + (if is_copy_named_generating p + then (*WN051014 kept strange old code ...*) + let fun sel (_,_,d,ts) = comp_ts (d, ts) + val cy' = (implode o drop_last o drop_last o explode o free2str) t + val ext = (last_elem o drop_last o explode o free2str) t + val vars' = map (free2str o snd o snd) pbt(*cpy-nam filtered_out*) + val vals = map sel oris + val cy_ext = (free2str o the) (assoc (vars'~~vals, cy'))^"_"^ext + in ([1], field, dsc, [mk_free (type_of t) cy_ext]):preori end + else ([1], field, dsc, [t]) + ) + handle _ => raise error ("cpy_nam: for "^(term2str t)); + +(*> val (field,(dsc,t)) = last_elem pbt; +> cpy_nam pbt (drop_last oris) (field,(dsc,t)); +val it = ([1],"#Find", + Const ("Descript.solutions","bool List.list => Tools.toreall"), + [Free ("x_i","bool List.list")]) *) + + +(*.match the actual arguments of a SubProblem with a model-pattern + and create an ori list (in root-pbl created from formalization). + expects ags:pats = 1:1, while copy-named are filtered out of pats; + copy-named pats are appended in order to get them into the model-items.*) +fun match_ags thy (pbt:pat list) ags = +(* val (thy, pbt, ags) = (thy, (#ppc o get_pbt) pI, ags); + val (thy, pbt, ags) = (thy, pats, ags); + *) + let fun flattup (i,(var,bool,str,itm_)) = (i,var,bool,str,itm_); + val pbt' = filter_out is_copy_named pbt; + val cy = filter is_copy_named pbt; + val oris' = matc thy pbt' ags []; + val cy' = map (cpy_nam pbt' oris') cy; + val ors = add_id (oris' @ cy'); + (*appended in order to get ^^^^^ them into the model-items*) + in (map flattup ors):ori list end; +(*vars as above .. +> match_ags thy pbt ags; +val it = + [(1,[1],"#Given",Const ("Descript.equality","bool => Tools.una"), + [Const # $ (# $ #) $ Free (#,#)]), + (2,[1],"#Given",Const ("Descript.solveFor","RealDef.real => Tools.una"), + [Free ("x","RealDef.real")]), + (3,[1],"#Find", + Const ("Descript.solutions","bool List.list => Tools.toreall"), + [Free ("x_i","bool List.list")])] : ori list*) + +(*.report part of the error-msg which is not available in match_args.*) +fun match_ags_msg pI stac ags = + let val s = !show_types + val _ = show_types:= true + val pats = (#ppc o get_pbt) pI + val msg = (dots 70^"\n" + ^"*** problem "^strs2str pI^" has the ...\n" + ^"*** model-pattern "^pats2str pats^"\n" + ^"*** stac '"^term2str stac^"' has the ...\n" + ^"*** arg-list "^terms2str ags^"\n" + ^dashs 70) + val _ = show_types:= s + in writeln msg end; + + +(*get the variables out of a pbl_; FIXME.WN.0311: is_copy_named ...obscure!!!*) +fun vars_of_pbl_ pbl_ = + let fun var_of_pbl_ (gfr,(dsc,t)) = t + in ((map var_of_pbl_) o (filter_out is_copy_named)) pbl_ end; +fun vars_of_pbl_' pbl_ = + let fun var_of_pbl_ (gfr,(dsc,t)) = t:term + in ((map var_of_pbl_)(* o (filter_out is_copy_named)*)) pbl_ end; + +fun overwrite_ppc thy itm ppc = + let + fun repl ppc' (_,_,_,_,itm_) [] = + raise error ("overwrite_ppc: " ^ (itm_2str_ (thy2ctxt thy) itm_) ^ + " not found") + | repl ppc' itm (p::ppc) = + if (#1 itm) = (#1 (p:itm)) then ppc' @ [itm] @ ppc + else repl (ppc' @ [p]) itm ppc + in repl [] itm ppc end; + +(*10.3.00: insert the already compiled itm into model; + ev. filter_out untouched (in FE: (0,...)) item related to insert-item *) +(* val ppc=pbl; + *) +fun insert_ppc thy itm ppc = + let + fun eq_untouched d ((0,_,_,_,itm_):itm) = (d = d_in itm_) + | eq_untouched _ _ = false; + val ppc' = + ( + (*writeln("### insert_ppc: itm= "^(itm2str_ itm));*) + case seek_ppc (#1 itm) ppc of + (* val SOME xxx = seek_ppc (#1 itm) ppc; + *) + SOME _ => (*itm updated in is_notyet_input WN.11.03*) + overwrite_ppc thy itm ppc + | NONE => (ppc @ [itm])); + in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end; + +(*from Isabelle/src/Pure/library.ML, _appends_ a new element*) +fun gen_ins' eq (x, xs) = if gen_mem eq (x, xs) then xs else xs @ [x]; + +fun eq_dsc ((_,_,_,_,itm_):itm, (_,_,_,_,iitm_):itm) = + (d_in itm_) = (d_in iitm_); +(*insert_ppc = insert_ppc' for appl_add', input_icalhd 11.03, + handles superfluous items carelessly*) +fun insert_ppc' itm itms = gen_ins' eq_dsc (itm, itms); +(* val eee = op=; + > gen_ins' eee (4,[1,3,5,7]); +val it = [1, 3, 5, 7, 4] : int list*) + + +(*. output the headline to a ppc .*) +fun header p_ pI mI = + case p_ of Pbl => Problem (if pI = e_pblID then [] else pI) + | Met => Method mI + | pos => raise error ("header called with "^ pos_2str pos); + + + +(* test-printouts --- +val _=writeln("### insert_ppc: (d,ts)="^((Syntax.string_of_term (thy2ctxt thy))(comp_dts thy(d,ts)))); + val _=writeln("### insert_ppc: pts= "^ +(strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) pts); + + + val sel = "#Given"; val Add_Given' ct = m; + + val sel = "#Find"; val Add_Find' (ct,_) = m; + val (p,_) = p; + val (_,_,f,nxt',_,pt')= specify_additem sel (ct,[]) (p,Pbl(*!!!!!!!*)) c pt; +-------------- + val sel = "#Given"; val Add_Given' (ct,_) = nxt; val (p,_) = p; + *) +fun specify_additem sel (ct,_) (p,Met) c pt = + let + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; + (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*) + val cpI = if pI = e_pblID then pI' else pI; + val cmI = if mI = e_metID then mI' else mI; + val {ppc,pre,prls,...} = get_met cmI + in case appl_add thy sel oris met ppc ct of + Add itm (*..union old input *) => + let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct; + *) + val met' = insert_ppc thy itm met; + (*val pt' = update_met pt p met';*) + val ((p,Met),_,_,pt') = + generate1 thy (case sel of + "#Given" => Add_Given' (ct, met') + | "#Find" => Add_Find' (ct, met') + | "#Relate"=> Add_Relation'(ct, met')) + Uistate (p,Met) pt + val pre' = check_preconds thy prls pre met' + val pb = foldl and_ (true, map fst pre') + (*val _=writeln("@@@ specify_additem: Met Add before nxt_spec")*) + val (p_,nxt) = + nxt_spec Met pb oris (dI',pI',mI') (pbl,met') + ((#ppc o get_pbt) cpI,ppc) (dI,pI,mI); + in ((p,p_), ((p,p_),Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (Method cmI, itms2itemppc thy met' pre'))), + nxt,Safe,pt') end + | Err msg => + let val pre' = check_preconds thy prls pre met + val pb = foldl and_ (true, map fst pre') + (*val _=writeln("@@@ specify_additem: Met Err before nxt_spec")*) + val (p_,nxt) = + nxt_spec Met pb oris (dI',pI',mI') (pbl,met) + ((#ppc o get_pbt) cpI,(#ppc o get_met) cmI) (dI,pI,mI); + in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end + end +(* val (p,_) = p; + *) +| specify_additem sel (ct,_) (p,_(*Frm, Pbl*)) c pt = + let + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; + val cpI = if pI = e_pblID then pI' else pI; + val cmI = if mI = e_metID then mI' else mI; + val {ppc,where_,prls,...} = get_pbt cpI; + in case appl_add thy sel oris pbl ppc ct of + Add itm (*..union old input *) => + (* val Add itm = appl_add thy sel oris pbl ppc ct; + *) + let + (*val _= writeln("###specify_additem: itm= "^(itm2str_ itm));*) + val pbl' = insert_ppc thy itm pbl + val ((p,Pbl),_,_,pt') = + generate1 thy (case sel of + "#Given" => Add_Given' (ct, pbl') + | "#Find" => Add_Find' (ct, pbl') + | "#Relate"=> Add_Relation'(ct, pbl')) + Uistate (p,Pbl) pt + val pre = check_preconds thy prls where_ pbl' + val pb = foldl and_ (true, map fst pre) + (*val _=writeln("@@@ specify_additem: Pbl Add before nxt_spec")*) + val (p_,nxt) = + nxt_spec Pbl pb oris (dI',pI',mI') (pbl',met) + (ppc,(#ppc o get_met) cmI) (dI,pI,mI); + val ppc = if p_= Pbl then pbl' else met; + in ((p,p_), ((p,p_),Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (header p_ pI cmI, + itms2itemppc thy ppc pre))), nxt,Safe,pt') end + + | Err msg => + let val pre = check_preconds thy prls where_ pbl + val pb = foldl and_ (true, map fst pre) + (*val _=writeln("@@@ specify_additem: Pbl Err before nxt_spec")*) + val (p_,nxt) = + nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met) + (ppc,(#ppc o get_met) cmI) (dI,pI,mI); + in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end + end; +(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt; + val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Met) c pt; + *) + +(* ori +val (msg,itm) = appl_add thy sel oris ppc ct; +val (Cor(d,ts)) = #5 itm; +map (atomty) ts; + +pre +*) + + +(* val Init_Proof' (fmz,(dI',pI',mI')) = m; + specify (Init_Proof' (fmz,(dI',pI',mI'))) e_pos' [] EmptyPtree; + *) +fun specify (Init_Proof' (fmz,(dI',pI',mI'))) (_:pos') (_:cid) (_:ptree)= + let (* either """"""""""""""" all empty or complete *) + val thy = assoc_thy dI'; + val oris = if dI' = e_domID orelse pI' = e_pblID then ([]:ori list) + else prep_ori fmz thy ((#ppc o get_pbt) pI'); + val (pt,c) = cappend_problem e_ptree [] e_istate (fmz,(dI',pI',mI')) + (oris,(dI',pI',mI'),e_term); + val {ppc,prls,where_,...} = get_pbt pI' + (*val pbl = init_pbl ppc; WN.9.03: done in Model/Refine_Problem + val pt = update_pbl pt [] pbl; + val pre = check_preconds thy prls where_ pbl + val pb = foldl and_ (true, map fst pre)*) + val (pbl, pre, pb) = ([], [], false) + in case mI' of + ["no_met"] => + (([],Pbl), (([],Pbl),Uistate), + Form' (PpcKF (0,EdUndef,(length []),Nundef, + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))), + Refine_Tacitly pI', Safe,pt) + | _ => + (([],Pbl), (([],Pbl),Uistate), + Form' (PpcKF (0,EdUndef,(length []),Nundef, + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))), + Model_Problem, + Safe,pt) + end + (*ONLY for STARTING modeling phase*) + | specify (Model_Problem' (_,pbl,met)) (pos as (p,p_)) c pt = + let (* val (Model_Problem' (_,pbl), pos as (p,p_)) = (m, (p,p_)); + *) + val (PblObj{origin=(oris,(dI',pI',mI'),_), spec=(dI,_,_),...}) = + get_obj I pt p + val thy' = if dI = e_domID then dI' else dI + val thy = assoc_thy thy' + val {ppc,prls,where_,...} = get_pbt pI' + val pre = check_preconds thy prls where_ pbl + val pb = foldl and_ (true, map fst pre) + val ((p,_),_,_,pt) = + generate1 thy (Model_Problem'([],pbl,met)) Uistate pos pt + val (_,nxt) = nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met) + (ppc,(#ppc o get_met) mI') (dI',pI',mI'); + in ((p,Pbl), ((p,p_),Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (Problem pI', itms2itemppc (assoc_thy dI') pbl pre))), + nxt, Safe, pt) end + +(*. called only if no_met is specified .*) + | specify (Refine_Tacitly' (pI,pIre,_,_,_)) (pos as (p,_)) c pt = + let (* val Refine_Tacitly' (pI,pIre,_,_,_) = m; + *) + val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, ...}) = + get_obj I pt p; + val {prls,met,ppc,thy,where_,...} = get_pbt pIre + (*val pbl = init_pbl ppc --- Model_Problem recognizes probl=[]*) + (*val pt = update_pbl pt p pbl; + val pt = update_orispec pt p + (string_of_thy thy, pIre, + if length met = 0 then e_metID else hd met);*) + val (domID, metID) = (string_of_thy thy, + if length met = 0 then e_metID else hd met) + val ((p,_),_,_,pt) = + generate1 thy (Refine_Tacitly'(pI,pIre,domID,metID,(*pbl*)[])) + Uistate pos pt + (*val pre = check_preconds thy prls where_ pbl + val pb = foldl and_ (true, map fst pre)*) + val (pbl, pre, pb) = ([], [], false) + in ((p,Pbl), (pos,Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (Problem pIre, itms2itemppc (assoc_thy dI') pbl pre))), + Model_Problem, Safe, pt) end + + | specify (Refine_Problem' (rfd as (pI,_))) pos c pt = + let val (pos,_,_,pt) = generate1 (assoc_thy "Isac.thy") + (Refine_Problem' rfd) Uistate pos pt + in (pos(*p,Pbl*), (pos(*p,Pbl*),Uistate), Problems (RefinedKF rfd), + Model_Problem, Safe, pt) end + +(* val (Specify_Problem' (pI, (ok, (itms, pre)))) = nxt; val (p,_) = p; + val (Specify_Problem' (pI, (ok, (itms, pre)))) = m; val (p,_) = p; + *) + | specify (Specify_Problem' (pI, (ok, (itms, pre)))) (pos as (p,_)) c pt = + let val (PblObj {origin=(oris,(dI',pI',mI'),_), spec=(dI,_,mI), + meth=met, ...}) = get_obj I pt p; + (*val pt = update_pbl pt p itms; + val pt = update_pblID pt p pI;*) + val thy = assoc_thy dI + val ((p,Pbl),_,_,pt)= + generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate pos pt + val dI'' = assoc_thy (if dI=e_domID then dI' else dI); + val mI'' = if mI=e_metID then mI' else mI; + (*val _=writeln("@@@ specify (Specify_Problem) before nxt_spec")*) + val (_,nxt) = nxt_spec Pbl ok oris (dI',pI',mI') (itms, met) + ((#ppc o get_pbt) pI,(#ppc o get_met) mI'') (dI,pI,mI); + in ((p,Pbl), (pos,Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (Problem pI, itms2itemppc dI'' itms pre))), + nxt, Safe, pt) end +(* val Specify_Method' mID = nxt; val (p,_) = p; + val Specify_Method' mID = m; + specify (Specify_Method' mID) (p,p_) c pt; + *) + | specify (Specify_Method' (mID,_,_)) (pos as (p,_)) c pt = + let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI), + meth=met, ...}) = get_obj I pt p; + val {ppc,pre,prls,...} = get_met mID + val thy = assoc_thy dI + val oris = add_field' thy ppc oris; + (*val pt = update_oris pt p oris; 20.3.02: repl. "#undef"*) + val dI'' = if dI=e_domID then dI' else dI; + val pI'' = if pI = e_pblID then pI' else pI; + val met = if met=[] then pbl else met; + val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris; + (*val pt = update_met pt p itms; + val pt = update_metID pt p mID*) + val (pos,_,_,pt)= + generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt + (*val _=writeln("@@@ specify (Specify_Method) before nxt_spec")*) + val (_,nxt) = nxt_spec Met (*ok*)true oris (dI',pI',mI') (pbl, itms) + ((#ppc o get_pbt) pI'',ppc) (dI'',pI'',mID); + in (pos, (pos,Uistate), + Form' (PpcKF (0,EdUndef,(length p),Nundef, + (Method mID, itms2itemppc (assoc_thy dI'') itms pre'))), + nxt, Safe, pt) end +(* val Add_Find' ct = nxt; val sel = "#Find"; + *) + | specify (Add_Given' ct) p c pt = specify_additem "#Given" ct p c pt + | specify (Add_Find' ct) p c pt = specify_additem "#Find" ct p c pt + | specify (Add_Relation' ct) p c pt=specify_additem"#Relate"ct p c pt +(* val Specify_Theory' domID = m; + val (Specify_Theory' domID, (p,p_)) = (m, pos); + *) + | specify (Specify_Theory' domID) (pos as (p,p_)) c pt = + let val p_ = case p_ of Met => Met | _ => Pbl + val thy = assoc_thy domID; + val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, + probl=pbl, spec=(dI,pI,mI),...}) = get_obj I pt p; + val mppc = case p_ of Met => met | _ => pbl; + val cpI = if pI = e_pblID then pI' else pI; + val {prls=per,ppc,where_=pwh,...} = get_pbt cpI + val cmI = if mI = e_metID then mI' else mI; + val {prls=mer,ppc=mpc,pre=mwh,...} = get_met cmI + val pre = + case p_ of + Met => (check_preconds thy mer mwh met) + | _ => (check_preconds thy per pwh pbl) + val pb = foldl and_ (true, map fst pre) + in if domID = dI + then let + (*val _=writeln("@@@ specify (Specify_Theory) THEN before nxt_spec")*) + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') + (pbl,met) (ppc,mpc) (dI,pI,mI); + in ((p,p_), (pos,Uistate), + Form'(PpcKF (0,EdUndef,(length p), Nundef, + (header p_ pI cmI, itms2itemppc thy mppc pre))), + nxt,Safe,pt) end + else (*FIXME: check ppc wrt. (new!) domID ..? still parsable?*) + let + (*val pt = update_domID pt p domID;11.8.03*) + val ((p,p_),_,_,pt) = generate1 thy (Specify_Theory' domID) + Uistate (p,p_) pt + (*val _=writeln("@@@ specify (Specify_Theory) ELSE before nxt_spec")*) + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') (pbl,met) + (ppc,mpc) (domID,pI,mI); + in ((p,p_), (pos,Uistate), + Form' (PpcKF (0, EdUndef, (length p),Nundef, + (header p_ pI cmI, itms2itemppc thy mppc pre))), + nxt, Safe,pt) end + end +(* itms2itemppc thy [](*mpc*) pre + *) + | specify m' _ _ _ = + raise error ("specify: not impl. for "^tac_2str m'); + +(* val (sel, Add_Given ct, ptp as (pt,(p,Pbl))) = ("#Given", tac, ptp); + val (sel, Add_Find ct, ptp as (pt,(p,Pbl))) = ("#Find", tac, ptp); + *) +fun nxt_specif_additem sel ct (ptp as (pt,(p,Pbl))) = + let + val (PblObj{meth=met,origin=(oris,(dI',pI',_),_), + probl=pbl,spec=(dI,pI,_),...}) = get_obj I pt p; + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; + val cpI = if pI = e_pblID then pI' else pI; + in case appl_add thy sel oris pbl ((#ppc o get_pbt) cpI) ct of + Add itm (*..union old input *) => +(* val Add itm = appl_add thy sel oris pbl ppc ct; + *) + let + (*val _=writeln("###nxt_specif_additem: itm= "^(itm2str_ itm));*) + val pbl' = insert_ppc thy itm pbl + val (tac,tac_) = + case sel of + "#Given" => (Add_Given ct, Add_Given' (ct, pbl')) + | "#Find" => (Add_Find ct, Add_Find' (ct, pbl')) + | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, pbl')) + val ((p,Pbl),c,_,pt') = + generate1 thy tac_ Uistate (p,Pbl) pt + in ([(tac,tac_,((p,Pbl),Uistate))], c, (pt',(p,Pbl))):calcstate' end + + | Err msg => + (*TODO.WN03 pass error-msgs to the frontend.. + FIXME ..and dont abuse a tactic for that purpose*) + ([(Tac msg, + Tac_ (theory "Pure", msg,msg,msg), + (e_pos', e_istate))], [], ptp) + end + +(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt; + val (_,_,f,nxt',_,pt')= nxt_specif_additem sel ct (p,Met) c pt; + *) + | nxt_specif_additem sel ct (ptp as (pt,(p,Met))) = + let + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; + val cmI = if mI = e_metID then mI' else mI; + in case appl_add thy sel oris met ((#ppc o get_met) cmI) ct of + Add itm (*..union old input *) => + let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct; + *) + val met' = insert_ppc thy itm met; + val (tac,tac_) = + case sel of + "#Given" => (Add_Given ct, Add_Given' (ct, met')) + | "#Find" => (Add_Find ct, Add_Find' (ct, met')) + | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, met')) + val ((p,Met),c,_,pt') = + generate1 thy tac_ Uistate (p,Met) pt + in ([(tac,tac_,((p,Met), Uistate))], c, (pt',(p,Met))) end + + | Err msg => ([(*tacis*)], [], ptp) + (*nxt_me collects tacis until not hide; here just no progress*) + end; + +(* ori +val (msg,itm) = appl_add thy sel oris ppc ct; +val (Cor(d,ts)) = #5 itm; +map (atomty) ts; + +pre +*) +fun ori2Coritm pbt ((i,v,f,d,ts):ori) = + (i,v,true,f, Cor ((d,ts),(((snd o snd o the o (find_first (eq1 d))) pbt) + handle _ => raise error ("ori2Coritm: dsc "^ + term2str d^ + "in ori, but not in pbt") + ,ts))):itm; +fun ori2Coritm (pbt:pat list) ((i,v,f,d,ts):ori) = + ((i,v,true,f, Cor ((d,ts),((snd o snd o the o + (find_first (eq1 d))) pbt,ts))):itm) + handle _ => (*dsc in oris, but not in pbl pat list: keep this dsc*) + ((i,v,true,f, Cor ((d,ts),(d,ts))):itm); + + +(*filter out oris which have same description in itms*) +fun filter_outs oris [] = oris + | filter_outs oris (i::itms) = + let val ors = filter_out ((curry op= ((d_in o #5) (i:itm))) o + (#4:ori -> term)) oris; + in filter_outs ors itms end; + +fun memI a b = member op = a b; +(*filter oris which are in pbt, too*) +fun filter_pbt oris pbt = + let val dscs = map (fst o snd) pbt + in filter ((memI dscs) o (#4: ori -> term)) oris end; + +(*.combine itms from pbl + met and complete them wrt. pbt.*) +(*FIXXXME.WN031205 complete_metitms doesnt handle incorrect itms !*) +local infix mem; +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun complete_metitms (oris:ori list) (pits:itm list) (mits:itm list) met = +(* val met = (#ppc o get_met) ["DiffApp","max_by_calculus"]; + *) + let val vat = max_vt pits; + val itms = pits @ + (filter ((curry (op mem) vat) o (#2:itm -> int list)) mits); + val ors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris; + val os = filter_outs ors itms; + (*WN.12.03?: does _NOT_ add itms from met ?!*) + in itms @ (map (ori2Coritm met) os) end +end; + + + +(*.complete model and guard of a calc-head .*) +local infix mem; +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun complete_mod_ (oris, mpc, ppc, probl) = + let val pits = filter_out ((curry op= false) o (#3: itm -> bool)) probl + val vat = if probl = [] then 1 else max_vt probl + val pors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris + val pors = filter_outs pors pits (*which are in pbl already*) + val pors = (filter_pbt pors ppc) (*which are in pbt, too*) + + val pits = pits @ (map (ori2Coritm ppc) pors) + val mits = complete_metitms oris pits [] mpc + in (pits, mits) end +end; + +fun some_spec ((odI, opI, omI):spec) ((dI, pI, mI):spec) = + (if dI = e_domID then odI else dI, + if pI = e_pblID then opI else pI, + if mI = e_metID then omI else mI):spec; + + +(*.find a next applicable tac (for calcstate) and update ptree + (for ev. finding several more tacs due to hide).*) +(*FIXXXME: unify ... fun nxt_specif = nxt_spec + applicable_in + specify !!*) +(*WN.24.10.03 ~~~~~~~~~~~~~~ -> tac -> tac_ -> -"- as arg*) +(*WN.24.10.03 fun nxt_solv = ...................................??*) +fun nxt_specif (tac as Model_Problem) (pt, pos as (p,p_)) = + let + val (PblObj{origin=(oris,ospec,_),probl,spec,...}) = get_obj I pt p + val (dI,pI,mI) = some_spec ospec spec + val thy = assoc_thy dI + val mpc = (#ppc o get_met) mI (*just for reuse complete_mod_*) + val {cas,ppc,...} = get_pbt pI + val pbl = init_pbl ppc (*fill in descriptions*) + (*--------------if you think, this should be done by the Dialog + in the java front-end, search there for WN060225-modelProblem----*) + val (pbl,met) = case cas of NONE => (pbl,[]) + | _ => complete_mod_ (oris, mpc, ppc, probl) + (*----------------------------------------------------------------*) + val tac_ = Model_Problem' (pI, pbl, met) + val (pos,c,_,pt) = generate1 thy tac_ Uistate pos pt + in ([(tac,tac_, (pos, Uistate))], c, (pt,pos)):calcstate' end + +(* val Add_Find ct = tac; + *) + | nxt_specif (Add_Given ct) ptp = nxt_specif_additem "#Given" ct ptp + | nxt_specif (Add_Find ct) ptp = nxt_specif_additem "#Find" ct ptp + | nxt_specif (Add_Relation ct) ptp = nxt_specif_additem"#Relate" ct ptp + +(*. called only if no_met is specified .*) + | nxt_specif (Refine_Tacitly pI) (ptp as (pt, pos as (p,_))) = + let val (PblObj {origin = (oris, (dI,_,_),_), ...}) = get_obj I pt p + val opt = refine_ori oris pI + in case opt of + SOME pI' => + let val {met,ppc,...} = get_pbt pI' + val pbl = init_pbl ppc + (*val pt = update_pbl pt p pbl ..done by Model_Problem*) + val mI = if length met = 0 then e_metID else hd met + val thy = assoc_thy dI + val (pos,c,_,pt) = + generate1 thy (Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[])) + Uistate pos pt + in ([(Refine_Tacitly pI, Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]), + (pos, Uistate))], c, (pt,pos)) end + | NONE => ([], [], ptp) + end + + | nxt_specif (Refine_Problem pI) (ptp as (pt, pos as (p,_))) = + let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_), + probl, ...}) = get_obj I pt p + val thy = if dI' = e_domID then dI else dI' + in case refine_pbl (assoc_thy thy) pI probl of + NONE => ([], [], ptp) + | SOME (rfd as (pI',_)) => + let val (pos,c,_,pt) = + generate1 (assoc_thy thy) + (Refine_Problem' rfd) Uistate pos pt + in ([(Refine_Problem pI, Refine_Problem' rfd, + (pos, Uistate))], c, (pt,pos)) end + end + + | nxt_specif (Specify_Problem pI) (pt, pos as (p,_)) = + let val (PblObj {origin=(oris,(dI,_,_),_),spec=(dI',pI',_), + probl, ...}) = get_obj I pt p; + val thy = assoc_thy (if dI' = e_domID then dI else dI'); + val {ppc,where_,prls,...} = get_pbt pI + val pbl as (_,(itms,_)) = + if pI'=e_pblID andalso pI=e_pblID + then (false, (init_pbl ppc, [])) + else match_itms_oris thy probl (ppc,where_,prls) oris(*FIXXXXXME?*) + (*FIXXXME~~~~~~~~~~~~~~~: take pbl and compare with new pI WN.8.03*) + val ((p,Pbl),c,_,pt)= + generate1 thy (Specify_Problem' (pI, pbl)) Uistate pos pt + in ([(Specify_Problem pI, Specify_Problem' (pI, pbl), + (pos,Uistate))], c, (pt,pos)) end + + (*transfers oris (not required in pbl) to met-model for script-env + FIXME.WN.8.03: application of several mIDs to SAME model?*) + | nxt_specif (Specify_Method mID) (ptp as (pt, pos as (p,_))) = + let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI), + meth=met, ...}) = get_obj I pt p; + val {ppc,pre,prls,...} = get_met mID + val thy = assoc_thy dI + val oris = add_field' thy ppc oris; + val dI'' = if dI=e_domID then dI' else dI; + val pI'' = if pI = e_pblID then pI' else pI; + val met = if met=[] then pbl else met;(*WN0602 what if more itms in met?*) + val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris; + val (pos,c,_,pt)= + generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt + in ([(Specify_Method mID, Specify_Method' (mID, oris, itms), + (pos,Uistate))], c, (pt,pos)) end + + | nxt_specif (Specify_Theory dI) (pt, pos as (p,Pbl)) = + let val (dI',_,_) = get_obj g_spec pt p + val (pos,c,_,pt) = + generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI) + Uistate pos pt + in (*FIXXXME: check if pbl can still be parsed*) + ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c, + (pt, pos)) end + + | nxt_specif (Specify_Theory dI) (pt, pos as (p,Met)) = + let val (dI',_,_) = get_obj g_spec pt p + val (pos,c,_,pt) = + generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI) + Uistate pos pt + in (*FIXXXME: check if met can still be parsed*) + ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c, + (pt, pos)) end + + | nxt_specif m' _ = + raise error ("nxt_specif: not impl. for "^tac2str m'); + +(*.get the values from oris; handle the term list w.r.t. penv.*) + +local infix mem; +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun vals_of_oris oris = + ((map (mkval' o (#5:ori -> term list))) o + (filter ((curry (op mem) 1) o (#2:ori -> int list)))) oris +end; + + + +(*.create a calc-tree with oris via an cas.refined pbl.*) +fun nxt_specify_init_calc (([],(dI,pI,mI)): fmz) = +(* val ([],(dI,pI,mI)) = (fmz, sp); + *) + if pI <> [] then (*comes from pbl-browser*) + let val {cas,met,ppc,thy,...} = get_pbt pI + val dI = if dI = "" then theory2theory' thy else dI + val thy = assoc_thy dI + val mI = if mI = [] then hd met else mI + val hdl = case cas of NONE => pblterm dI pI | SOME t => t + val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI)) + ([], (dI,pI,mI), hdl) + val pt = update_spec pt [] (dI,pI,mI) + val pits = init_pbl' ppc + val pt = update_pbl pt [] pits + in ((pt,([],Pbl)), []): calcstate end + else if mI <> [] then (*comes from met-browser*) + let val {ppc,...} = get_met mI + val dI = if dI = "" then "Isac.thy" else dI + val thy = assoc_thy dI + val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI)) + ([], (dI,pI,mI), e_term(*FIXME met*)) + val pt = update_spec pt [] (dI,pI,mI) + val mits = init_pbl' ppc + val pt = update_met pt [] mits + in ((pt,([],Met)), []) end + else (*completely new example*) + let val (pt,_) = cappend_problem e_ptree [] e_istate ([], e_spec) + ([], e_spec, e_term) + in ((pt,([],Pbl)), []) end +(* val (fmz, (dI,pI,mI)) = (fmz, sp); + *) + | nxt_specify_init_calc (fmz:fmz_,(dI,pI,mI):spec) = + let (* either """"""""""""""" all empty or complete *) + val thy = assoc_thy dI + val (pI, pors, mI) = + if mI = ["no_met"] + then let val pors = prep_ori fmz thy ((#ppc o get_pbt) pI) + val pI' = refine_ori' pors pI; + in (pI', pors (*refinement over models with diff.prec only*), + (hd o #met o get_pbt) pI') end + else (pI, prep_ori fmz thy ((#ppc o get_pbt) pI), mI) + val {cas,ppc,thy=thy',...} = get_pbt pI (*take dI from _refined_ pbl*) + val dI = theory2theory' (maxthy thy thy'); + val hdl = case cas of + NONE => pblterm dI pI + | SOME t => subst_atomic ((vars_of_pbl_' ppc) + ~~~ vals_of_oris pors) t + val (pt,_) = cappend_problem e_ptree [] e_istate (fmz,(dI,pI,mI)) + (pors,(dI,pI,mI),hdl) + (*val pbl = init_pbl ppc WN.9.03: done by Model/Refine_Problem + val pt = update_pbl pt [] pbl*) + in ((pt,([],Pbl)), fst3 (nxt_specif Model_Problem (pt, ([],Pbl)))) + end; + + + +(*18.12.99*) +fun get_spec_form (m:tac_) ((p,p_):pos') (pt:ptree) = +(* case appl_spec p pt m of /// 19.1.00 + Notappl e => Error' (Error_ e) + | Appl => +*) let val (_,_,f,_,_,_) = specify m (p,p_) [] pt + in f end; + + +(*fun tag_form thy (formal, given) = cterm_of thy + (((head_of o term_of) given) $ (term_of formal)); WN100819*) +fun tag_form thy (formal, given) = + (let val gf = (head_of given) $ formal; + val _ = cterm_of thy gf + in gf end) + handle _ => raise error ("calchead.tag_form: " ^ + Syntax.string_of_term (thy2ctxt thy) given ^ + " .. " ^ + Syntax.string_of_term (thy2ctxt thy) formal ^ + " ..types do not match"); +(* val formal = (the o (parse thy)) "[R::real]"; +> val given = (the o (parse thy)) "fixed_values (cs::real list)"; +> tag_form thy (formal, given); +val it = "fixed_values [R]" : cterm +*) +fun chktyp thy (n, fs, gs) = + ((writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) fs; + (writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) gs; + tag_form thy (nth n fs, nth n gs)); + +fun chktyps thy (fs, gs) = map (tag_form thy) (fs ~~ gs); + +(* ##################################################### + find the failing item: +> val n = 2; +> val tag__form = chktyp (n,formals,givens); +> (type_of o term_of o (nth n)) formals; +> (type_of o term_of o (nth n)) givens; +> atomty ((term_of o (nth n)) formals); +> atomty ((term_of o (nth n)) givens); +> atomty (term_of tag__form); +> use_thy"isa-98-1-HOL-plus/knowl-base/DiffAppl"; + ##################################################### *) + +(* ##################################################### + testdata setup +val origin = ["sqrt(9+4*x)=sqrt x + sqrt(5+x)","x::rat","(+0)"]; +val formals = map (the o (parse thy)) origin; + +val given = ["equation (lhs=rhs)", + "bound_variable bdv", (* TODO type *) + "error_bound apx"]; +val where_ = ["e is_root_equation_in bdv", + "bdv is_var", + "apx is_const_expr"]; +val find = ["L::rat set"]; +val with_ = ["L = {bdv. || ((%x. lhs) bdv) - ((%x. rhs) bdv) || < apx}"]; +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_); +val givens = map (the o (parse thy)) given; + +val tag__forms = chktyps (formals, givens); +map ((atomty) o term_of) tag__forms; + ##################################################### *) + + +(* check pbltypes, announces one failure a time *) +(*fun chk_vars ctppc = + let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} = + appc flat (mappc (vars o term_of) ctppc) + in if (wh\\gi) <> [] then ("wh\\gi",wh\\gi) + else if (re\\(gi union fi)) <> [] + then ("re\\(gi union fi)",re\\(gi union fi)) + else ("ok",[]) end;*) +fun chk_vars ctppc = + let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} = + appc flat (mappc vars ctppc) + val chked = subtract op = gi wh + in if chked <> [] then ("wh\\gi", chked) + else let val chked = subtract op = (union op = gi fi) re + in if chked <> [] + then ("re\\(gi union fi)", chked) + else ("ok", []) + end + end; + +(* check a new pbltype: variables (Free) unbound by given, find*) +fun unbound_ppc ctppc = + let val {Given=gi,Find=fi,Relate=re,...} = + appc flat (mappc vars ctppc) + in distinct (*re\\(gi union fi)*) + (subtract op = (union op = gi fi) re) end; +(* +> val org = {Given=["[R=(R::real)]"],Where=[], + Find=["[A::real]"],With=[], + Relate=["[A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"] + }:string ppc; +> val ctppc = mappc (the o (parse thy)) org; +> unbound_ppc ctppc; +val it = [("a","RealDef.real"),("b","RealDef.real")] : (string * typ) list +*) + + +(* f, a binary operator, is nested rightassociative *) +fun foldr1 f xs = + let + fun fld f (x::[]) = x + | fld f (x::x'::[]) = f (x',x) + | fld f (x::x'::xs) = f (fld f (x'::xs),x); + in ((fld f) o rev) xs end; +(* +> val (SOME ct) = parse thy "[a=b,c=d,e=f]"; +> val ces = map (cterm_of thy) (isalist2list (term_of ct)); +> val conj = foldr1 HOLogic.mk_conj (isalist2list (term_of ct)); +> cterm_of thy conj; +val it = "(a = b & c = d) & e = f" : cterm +*) + +(* f, a binary operator, is nested leftassociative *) +fun foldl1 f (x::[]) = x + | foldl1 f (x::x'::[]) = f (x,x') + | foldl1 f (x::x'::xs) = f (x,foldl1 f (x'::xs)); +(* +> val (SOME ct) = parse thy "[a=b,c=d,e=f,g=h]"; +> val ces = map (cterm_of thy) (isalist2list (term_of ct)); +> val conj = foldl1 HOLogic.mk_conj (isalist2list (term_of ct)); +> cterm_of thy conj; +val it = "a = b & c = d & e = f & g = h" : cterm +*) + + +(* called only once, if a Subproblem has been located in the script*) +fun nxt_model_pbl (Subproblem'((_,pblID,metID),_,_,_,_)) ptp = +(* val (Subproblem'((_,pblID,metID),_,_,_,_),ptp) = (m', (pt,(p,p_))); + *) + (case metID of + ["no_met"] => + (snd3 o hd o fst3) (nxt_specif (Refine_Tacitly pblID) ptp) + | _ => (snd3 o hd o fst3) (nxt_specif Model_Problem ptp)) + (*all stored in tac_ itms ^^^^^^^^^^*) + | nxt_model_pbl tac_ _ = + raise error ("nxt_model_pbl: called by tac= "^tac_2str tac_); +(* run subp_rooteq.sml '' + until nxt=("Subproblem",Subproblem ("SqRoot.thy",["univariate","equation"])) +> val (_, (Subproblem'((_,pblID,metID),_,_,_,_),_,_,_,_,_)) = + (last_elem o drop_last) ets''; +> val mst = (last_elem o drop_last) ets''; +> nxt_model_pbl mst; +val it = Refine_Tacitly ["univariate","equation"] : tac +*) + +(*fun eq1 d (_,(d',_)) = (d = d'); ---modspec.sml*) +fun eq4 v (_,vts,_,_,_) = member op = vts v; +fun eq5 (_,_,_,_,itm_) (_,_,_,d,_) = d_in itm_ = d; + + + +(* + writeln (oris2str pors); + + writeln (itms2str_ thy pits); + writeln (itms2str_ thy mits); + *) + + +(*.complete _NON_empty calc-head for autocalc (sub-)pbl from oris + + met from fmz; assumes pos on PblObj, meth = [].*) +fun complete_mod (pt, pos as (p, p_):pos') = +(* val (pt, (p, _)) = (pt, p); + val (pt, (p, _)) = (pt, pos); + *) + let val _= if p_ <> Pbl + then writeln("###complete_mod: only impl.for Pbl, called with "^ + pos'2str pos) else () + val (PblObj{origin=(oris, ospec, hdl), probl, spec,...}) = + get_obj I pt p + val (dI,pI,mI) = some_spec ospec spec + val mpc = (#ppc o get_met) mI + val ppc = (#ppc o get_pbt) pI + val (pits, mits) = complete_mod_ (oris, mpc, ppc, probl) + val pt = update_pblppc pt p pits + val pt = update_metppc pt p mits + in (pt, (p,Met):pos') end +; +(*| complete_mod (pt, pos as (p, Met):pos') = + raise error ("###complete_mod: only impl.for Pbl, called with "^ + pos'2str pos);*) + +(*.complete _EMPTY_ calc-head for autocalc (sub-)pbl from oris(+met from fmz); + oris and spec (incl. pbl-refinement) given from init_calc or SubProblem .*) +fun all_modspec (pt, (p,_):pos') = +(* val (pt, (p,_)) = ptp; + *) + let val (PblObj{fmz=(fmz_,_), origin=(pors, spec as (dI,pI,mI), hdl), + ...}) = get_obj I pt p; + val thy = assoc_thy dI; + val {ppc,...} = get_met mI; + val mors = prep_ori fmz_ thy ppc; + val pt = update_pblppc pt p (map (ori2Coritm ppc) pors); + val pt = update_metppc pt p (map (ori2Coritm ppc) mors); + val pt = update_spec pt p (dI,pI,mI); + in (pt, (p,Met): pos') end; + +(*WN.12.03: use in nxt_spec, too ? what about variants ???*) +fun is_complete_mod_ ([]: itm list) = false + | is_complete_mod_ itms = + foldl and_ (true, (map #3 itms)); +fun is_complete_mod (pt, pos as (p, Pbl): pos') = + if (is_pblobj o (get_obj I pt)) p + then (is_complete_mod_ o (get_obj g_pbl pt)) p + else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos) + | is_complete_mod (pt, pos as (p, Met)) = + if (is_pblobj o (get_obj I pt)) p + then (is_complete_mod_ o (get_obj g_met pt)) p + else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos) + | is_complete_mod (_, pos) = + raise error ("is_complete_mod called by "^pos'2str pos^ + " (should be Pbl or Met)"); + +(*.have (thy, pbl, met) _all_ been specified explicitly ?.*) +fun is_complete_spec (pt, pos as (p,_): pos') = + if (not o is_pblobj o (get_obj I pt)) p + then raise error ("is_complete_spec: called by PrfObj at "^pos'2str pos) + else let val (dI,pI,mI) = get_obj g_spec pt p + in dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID end; +(*.complete empty items in specification from origin (pbl, met ev.refined); + assumes 'is_complete_mod'.*) +fun complete_spec (pt, pos as (p,_): pos') = + let val PblObj {origin = (_,ospec,_), spec,...} = get_obj I pt p + val pt = update_spec pt p (some_spec ospec spec) + in (pt, pos) end; + +fun is_complete_modspec ptp = + is_complete_mod ptp andalso is_complete_spec ptp; + + + + +fun pt_model (PblObj {meth,spec,origin=(_,spec',hdl),...}) Met = +(* val ((PblObj {meth,spec,origin=(_,spec',hdl),...}), Met) = (ppobj, p_); + *) + let val (_,_,metID) = get_somespec' spec spec' + val pre = + if metID = e_metID then [] + else let val {prls,pre=where_,...} = get_met metID + val pre = check_preconds' prls where_ meth 0 + in pre end + val allcorrect = is_complete_mod_ meth + andalso foldl and_ (true, (map #1 pre)) + in ModSpec (allcorrect, Met, hdl, meth, pre, spec) end + | pt_model (PblObj {probl,spec,origin=(_,spec',hdl),...}) _(*Frm,Pbl*) = +(* val ((PblObj {probl,spec,origin=(_,spec',hdl),...}),_) = (ppobj, p_); + *) + let val (_,pI,_) = get_somespec' spec spec' + val pre = + if pI = e_pblID then [] + else let val {prls,where_,cas,...} = get_pbt pI + val pre = check_preconds' prls where_ probl 0 + in pre end + val allcorrect = is_complete_mod_ probl + andalso foldl and_ (true, (map #1 pre)) + in ModSpec (allcorrect, Pbl, hdl, probl, pre, spec) end; + + +fun pt_form (PrfObj {form,...}) = Form form + | pt_form (PblObj {probl,spec,origin=(_,spec',_),...}) = + let val (dI, pI, _) = get_somespec' spec spec' + val {cas,...} = get_pbt pI + in case cas of + NONE => Form (pblterm dI pI) + | SOME t => Form (subst_atomic (mk_env probl) t) + end; +(*vvv takes the tac _generating_ the formula=result, asm ok.... +fun pt_result (PrfObj {result=(t,asm), tac,...}) = + (Form t, + if null asm then NONE else SOME asm, + SOME tac) + | pt_result (PblObj {result=(t,asm), origin = (_,ospec,_), spec,...}) = + let val (_,_,metID) = some_spec ospec spec + in (Form t, + if null asm then NONE else SOME asm, + if metID = e_metID then NONE else SOME (Apply_Method metID)) end; +-------------------------------------------------------------------------*) + + +(*.pt_extract returns + # the formula at pos + # the tactic applied to this formula + # the list of assumptions generated at this formula + (by application of another tac to the preceding formula !) + pos is assumed to come from the frontend, ie. generated by moveDown.*) +(*cannot be in ctree.sml, because ModSpec has to be calculated*) +fun pt_extract (pt,([],Res)) = +(* val (pt,([],Res)) = ptp; + *) + let val (f, asm) = get_obj g_result pt [] + in (Form f, NONE, asm) end +(* val p = [3,2]; + *) + | pt_extract (pt,(p,Res)) = +(* val (pt,(p,Res)) = ptp; + *) + let val (f, asm) = get_obj g_result pt p + val tac = if last_onlev pt p + then if is_pblobj' pt (lev_up p) + then let val (PblObj{spec=(_,pI,_),...}) = + get_obj I pt (lev_up p) + in if pI = e_pblID then NONE + else SOME (Check_Postcond pI) end + else SOME End_Trans (*WN0502 TODO for other branches*) + else let val p' = lev_on p + in if is_pblobj' pt p' + then let val (PblObj{origin = (_,(dI,pI,_),_),...}) = + get_obj I pt p' + in SOME (Subproblem (dI, pI)) end + else if f = get_obj g_form pt p' + then SOME (get_obj g_tac pt p') + (*because this Frm ~~~is not on worksheet*) + else SOME (Take (term2str (get_obj g_form pt p'))) + end + in (Form f, tac, asm) end + + | pt_extract (pt, pos as (p,p_(*Frm,Pbl*))) = +(* val (pt, pos as (p,p_(*Frm,Pbl*))) = ptp; + val (pt, pos as (p,p_(*Frm,Pbl*))) = (pt, p); + *) + let val ppobj = get_obj I pt p + val f = if is_pblobj ppobj then pt_model ppobj p_ + else get_obj pt_form pt p + val tac = g_tac ppobj + in (f, SOME tac, []) end; + + +(**. get the formula from a ctree-node: + take form+res from PblObj and 1.PrfObj and (PrfObj after PblObj) + take res from all other PrfObj's .**) +(*designed for interSteps, outcommented 04 in favour of calcChangedEvent*) +fun formres p (Nd (PblObj {origin = (_,_, h), result = (r, _),...}, _)) = + [("headline", (p, Frm), h), + ("stepform", (p, Res), r)] + | formres p (Nd (PrfObj {form, result = (r, _),...}, _)) = + [("stepform", (p, Frm), form), + ("stepform", (p, Res), r)]; + +fun form p (Nd (PrfObj {result = (r, _),...}, _)) = + [("stepform", (p, Res), r)] + +(*assumes to take whole level, in particular hd -- for use in interSteps*) +fun get_formress fs p [] = flat fs + | get_formress fs p (nd::nds) = + (* start with 'form+res' and continue with trying 'res' only*) + get_forms (fs @ [formres p nd]) (lev_on p) nds +and get_forms fs p [] = flat fs + | get_forms fs p (nd::nds) = + if is_pblnd nd + (* start again with 'form+res' ///ugly repeat with Check_elementwise + then get_formress (fs @ [formres p nd]) (lev_on p) nds *) + then get_forms (fs @ [formres p nd]) (lev_on p) nds + (* continue with trying 'res' only*) + else get_forms (fs @ [form p nd]) (lev_on p) nds; + +(**.get an 'interval' 'from' 'to' of formulae from a ptree.**) +(*WN050219 made robust against _'to' below or after Complete nodes + by handling exn caused by move_dn*) +(*WN0401 this functionality belongs to ctree.sml, +but fetching a calc_head requires calculations defined in modspec.sml +transfer to ME/me.sml !!! +WN051224 ^^^ doesnt hold any longer, since only the headline of a calc_head +is returned !!!!!!!!!!!!! +*) +fun eq_pos' (p1,Frm) (p2,Frm) = p1 = p2 + | eq_pos' (p1,Res) (p2,Res) = p1 = p2 + | eq_pos' (p1,Pbl) (p2,p2_) = p1 = p2 andalso (case p2_ of + Pbl => true + | Met => true + | _ => false) + | eq_pos' (p1,Met) (p2,p2_) = p1 = p2 andalso (case p2_ of + Pbl => true + | Met => true + | _ => false) + | eq_pos' _ _ = false; + +(*.get an 'interval' from the ctree; 'interval' is w.r.t. the + total ordering Position#compareTo(Position p) in the java-code +val get_interval = fn + : pos' -> : from is "move_up 1st-element" to return + pos' -> : to the last element to be returned; from < to + int -> : level: 0 gets the flattest sub-tree possible + >999 gets the deepest sub-tree possible + ptree -> : + (pos' * : of the formula + Term.term) : the formula + list +.*) +fun get_interval from to level pt = +(* val (from,level) = (f,lev); + val (from, to, level) = (([3, 2, 1], Res), ([],Res), 9999); + *) + let fun get_inter c (from:pos') (to:pos') lev pt = +(* val (c, from, to, lev) = ([], from, to, level); + ------for recursion....... + val (c, from:pos', to:pos') = (c @ [(from, f)], move_dn [] pt from, to); + *) + if eq_pos' from to orelse from = ([],Res) + (*orelse ... avoids Exception- PTREE "end of calculation" raised, + if 'to' has values NOT generated by move_dn, see systest/me.sml + TODO.WN0501: introduce an order on pos' and check "from > to".. + ...there is an order in Java! + WN051224 the hack got worse with returning term instead ptform*) + then let val (f,_,_) = pt_extract (pt, from) + in case f of + ModSpec (_,_,headline,_,_,_) => c @ [(from, headline)] + | Form t => c @ [(from, t)] + end + else + if lev < lev_of from + then (get_inter c (move_dn [] pt from) to lev pt) + handle (PTREE _(*from move_dn too far*)) => c + else let val (f,_,_) = pt_extract (pt, from) + val term = case f of + ModSpec (_,_,headline,_,_,_)=> headline + | Form t => t + in (get_inter (c @ [(from, term)]) + (move_dn [] pt from) to lev pt) + handle (PTREE _(*from move_dn too far*)) + => c @ [(from, term)] end + in get_inter [] from to level pt end; + +(*for tests*) +fun posform2str (pos:pos', form) = + "("^ pos'2str pos ^", "^ + (case form of + Form f => term2str f + | ModSpec c => term2str (#3 c(*the headline*))) + ^")"; +fun posforms2str pfs = (strs2str' o (map (curry op ^ "\n")) o + (map posform2str)) pfs; +fun posterm2str (pos:pos', t) = + "("^ pos'2str pos ^", "^term2str t^")"; +fun posterms2str pfs = (strs2str' o (map (curry op ^ "\n")) o + (map posterm2str)) pfs; + + +(*WN050225 omits the last step, if pt is incomplete*) +fun show_pt pt = + writeln (posterms2str (get_interval ([],Frm) ([],Res) 99999 pt)); + +(*.get a calchead from a PblObj-node in the ctree; + preconditions must be calculated.*) +fun get_ocalhd (pt, pos' as (p,Pbl):pos') = + let val PblObj {origin = (oris, ospec, hdf'), spec, probl,...} = + get_obj I pt p + val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec)) + val pre = check_preconds (assoc_thy"Isac.thy") prls where_ probl + in (ocalhd_complete probl pre spec, Pbl, hdf', probl, pre, spec):ocalhd end +| get_ocalhd (pt, pos' as (p,Met):pos') = + let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'), + spec, meth,...} = + get_obj I pt p + val {prls,pre,...} = get_met (#3 (some_spec ospec spec)) + val pre = check_preconds (assoc_thy"Isac.thy") prls pre meth + in (ocalhd_complete meth pre spec, Met, hdf', meth, pre, spec):ocalhd end; + +(*.at the activeFormula set the Model, the Guard and the Specification + to empty and return a CalcHead; + the 'origin' remains (for reconstructing all that).*) +fun reset_calchead (pt, pos' as (p,_):pos') = + let val PblObj {origin = (_, _, hdf'),...} = get_obj I pt p + val pt = update_pbl pt p [] + val pt = update_met pt p [] + val pt = update_spec pt p e_spec + in (pt, (p,Pbl):pos') end; + +(*---------------------------------------------------------------------*) +end + +open CalcHead; +(*---------------------------------------------------------------------*) + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/ctree.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/ctree.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,2154 @@ +(* use"../ME/ctree.sml"; + use"ME/ctree.sml"; + use"ctree.sml"; + W.N.26.10.99 + +writeln (pr_ptree pr_short pt); + +val Nd ( _, ns) = pt; + +*) + +(*structure Ptree (**): PTREE (**) = ###### outcommented ######*) +signature PTREE = +sig + type ptree + type envp + val e_ptree : ptree + exception PTREE of string + type branch + type ostate + type cellID + type cid + type posel + type pos + type pos' + type loc + type domID + type pblID + type metID + type spec + type 'a ppc + type con + type subs + type subst + type env + type ets + val ets2str : ets -> string + type item + type tac + type tac_ + val tac_2str : tac_ -> string + type safe + val safe2str : safe -> string + + type meth + val cappend_atomic : ptree -> pos -> loc -> cterm' -> tac + -> cterm' -> ostate -> cid -> ptree * posel list * cid + val cappend_form : ptree + -> pos -> loc -> cterm' -> cid -> ptree * pos * cid + val cappend_parent : ptree -> pos -> loc -> cterm' -> tac + -> branch -> cid -> ptree * int list * cid + val cappend_problem : ptree -> posel list(*FIXME*) -> loc + -> cterm' list * spec -> cid -> ptree * int list * cellID list + val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos + + type ppobj + val g_branch : ppobj -> branch + val g_cell : ppobj -> cid + val g_args : ppobj -> (int * (term list)) list (*args of scr*) + val g_form : ppobj -> cterm' + val g_loc : ppobj -> loc + val g_met : ppobj -> meth + val g_domID : ppobj -> domID + val g_metID : ppobj -> metID + val g_model : ppobj -> cterm' ppc + val g_tac : ppobj -> tac + val g_origin : ppobj -> cterm' list * spec + val g_ostate : ppobj -> ostate + val g_pbl : ppobj -> pblID * item ppc + val g_result : ppobj -> cterm' + val g_spec : ppobj -> spec +(* val get_all : (ppobj -> 'a) -> ptree -> 'a list + val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *) + val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a + val gpt_cell : ptree -> cid + val par_pblobj : ptree -> pos -> pos + val pre_pos : pos -> pos + val lev_dn : int list -> int list + val lev_on : pos -> posel list + val lev_pred : pos -> pos + val lev_up : pos -> pos +(* val pr_cell : pos -> ppobj -> string + val pr_pos : int list -> string *) + val pr_ptree : (pos -> ppobj -> string) -> ptree -> string + val pr_short : pos -> ppobj -> string +(* val repl : 'a list -> int -> 'a -> 'a list + val repl_app : 'a list -> int -> 'a -> 'a list + val repl_branch : branch -> ppobj -> ppobj + val repl_domID : domID -> ppobj -> ppobj + val repl_form : cterm' -> ppobj -> ppobj + val repl_met : item ppc -> ppobj -> ppobj + val repl_metID : metID -> ppobj -> ppobj + val repl_model : cterm' list -> ppobj -> ppobj + val repl_tac : tac -> ppobj -> ppobj + val repl_pbl : item ppc -> ppobj -> ppobj + val repl_pblID : pblID -> ppobj -> ppobj + val repl_result : cterm' -> ostate -> ppobj -> ppobj + val repl_spec : spec -> ppobj -> ppobj + val repl_subs : (string * string) list -> ppobj -> ppobj *) + val rootthy : ptree -> domID +(* val test_trans : ppobj -> bool + val uni__asm : (string * pos) list -> ppobj -> ppobj + val uni__cid : cellID list -> ppobj -> ppobj *) + val union_asm : ptree -> pos -> (string * pos) list -> ptree + val union_cid : ptree -> pos -> cellID list -> ptree + val update_branch : ptree -> pos -> branch -> ptree + val update_domID : ptree -> pos -> domID -> ptree + val update_met : ptree -> pos -> meth -> ptree + val update_metppc : ptree -> pos -> item ppc -> ptree + val update_metID : ptree -> pos -> metID -> ptree + val update_tac : ptree -> pos -> tac -> ptree + val update_pbl : ptree -> pos -> pblID * item ppc -> ptree + val update_pblppc : ptree -> pos -> item ppc -> ptree + val update_pblID : ptree -> pos -> pblID -> ptree + val update_spec : ptree -> pos -> spec -> ptree + val update_subs : ptree -> pos -> (string * string) list -> ptree + + val rep_pblobj : ppobj + -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc, + origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc, + result:cterm', spec:spec} + val rep_prfobj : ppobj + -> {branch:branch, cell:cid, form:cterm', loc:loc, tac:tac, + ostate:ostate, result:cterm'} +end + +(* -------------- +structure Ptree (**): PTREE (**) = +struct + -------------- *) + +type env = (term * term) list; + + +datatype branch = + NoBranch | AndB | OrB + | TransitiveB (* FIXXXME.8.03: set branch from met in Apply_Method + FIXXXME.0402: -"- in Begin_Trans'*) + | SequenceB | IntersectB | CollectB | MapB; +fun branch2str NoBranch = "NoBranch" + | branch2str AndB = "AndB" + | branch2str OrB = "OrB" + | branch2str TransitiveB = "TransitiveB" + | branch2str SequenceB = "SequenceB" + | branch2str IntersectB = "IntersectB" + | branch2str CollectB = "CollectB" + | branch2str MapB = "MapB"; + +datatype ostate = + Incomplete | Complete | Inconsistent(*WN041020 latter unused*); +fun ostate2str Incomplete = "Incomplete" + | ostate2str Complete = "Complete" + | ostate2str Inconsistent = "Inconsistent"; + +type cellID = int; +type cid = cellID list; + +type posel = int; (* roundabout for (some of) nice signatures *) +type pos = posel list; +val pos2str = ints2str'; +datatype pos_ = + Pbl (*PblObj-position: problem-type*) + | Met (*PblObj-position: method*) + | Frm (*PblObj-position: -> Pbl in ME (not by moveDown !) + | PrfObj-position: formula*) + | Res (*PblObj | PrfObj-position: result*) + | Und; (*undefined*) +fun pos_2str Pbl = "Pbl" + | pos_2str Met = "Met" + | pos_2str Frm = "Frm" + | pos_2str Res = "Res" + | pos_2str Und = "Und"; + +type pos' = pos * pos_; +(*WN.12.03 remembering interator (pos * pos_) for ptree + pos : lev_on, lev_dn, lev_up, + lev_onFrm, lev_dnRes (..see solve Apply_Method !) + pos_: +# generate1 sets pos_ if possible ...?WN0502?NOT... +# generate1 does NOT set pos, because certain nodes can be lev_on OR lev_dn + exceptions: Begin/End_Trans +# thus generate(1) called in +.# assy, locate_gen +.# nxt_solv (tac_ -cases); general case: + val pos' = case pos' of (p,Res) => (lev_on p',Res) | _ => pos' +# WN050220, S(604): + generate1...(Rewrite(f,..,res))..(pos, pos_) + cappend_atomic.................pos ////// gets f+res always!!! + cut_tree....................pos, pos_ +*) +fun pos'2str (p,p_) = pair2str (ints2str' p, pos_2str p_); +fun pos's2str ps = (strs2str' o (map pos'2str)) ps; +val e_pos' = ([],Und):pos'; + +fun res2str (t, ts) = pair2str (term2str t, terms2str ts); +fun asm2str (t, p:pos) = pair2str (term2str t, ints2str' p); +fun asms2str asms = (strs2str' o (map asm2str)) asms; + + + +(*26.4.02: never used after introduction of scripts !!! +type loc = loc_ * (* + interpreter-state *) + (loc_ * rls') (* -"- for script of the ruleset*) + option; +val e_loc = ([],NONE):loc; +val ee_loc = (e_loc,e_loc);*) + + +datatype safe = Sundef | Safe | Unsafe | Helpless; +fun safe2str Sundef = "Sundef" + | safe2str Safe = "Safe" + | safe2str Unsafe = "Unsafe" + | safe2str Helpless = "Helpless"; + +type subs = cterm' list; (*16.11.00 for FE-KE*) +val e_subs = ["(bdv, x)"]; + +(*._sub_stitution as strings of _e_qualities.*) +type sube = cterm' list; +val e_sube = []:cterm' list; +fun sube2str s = strs2str s; + +(*._sub_stitution as _t_erms of _e_qualities.*) +type subte = term list; +val e_subte = []:term list; +fun subte2str ss = terms2str ss; + +fun subte2sube ss = map term2str ss; + +fun subst2subs s = map (pair2str o + (apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o + (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s; +fun subst2subs' s = map ((apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o + (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s; +fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s; +(*> subs2subst thy ["(bdv,x)","(err,#0)"]; +val it = + [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")), + (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))] + : (term * term) list*) +(*["bdv=x","err=0"] ---> [(bdv,x), (err,0)]*) +fun sube2subst thy s = map (dest_equals' o term_of o the o (parse thy)) s; +(* val ts = sube2subst thy ["bdv=x","err=0"]; + subst2str' ts; + *) +fun sube2subte ss = map str2term ss; + + +fun isasub2subst isasub = ((map isapair2pair) o isalist2list) isasub; + + +type scrstate = (*state for script interpreter*) + env(*stack*) (*used to instantiate tac for checking assod + 12.03.noticed: e_ not updated during execution ?!?*) + * loc_ (*location of tac in script*) + * term option(*argument of curried functions*) + * term (*value obtained by tac executed + updated also after a derivation by 'new_val'*) + * safe (*estimation of how result will be obtained*) + * bool; (*true = strongly .., false = weakly associated: + only used during ass_dn/up*) +val e_scrstate = ([],[],NONE,e_term,Sundef,false):scrstate; + + +(*21.8.02 ---> definitions.sml for datatype scr +type rrlsstate = (*state for reverse rewriting*) + (term * (*the current formula*) + rule list (*of reverse rewrite set (#1#)*) + list * (*may be serveral, eg. in norm_rational*) + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) + (term * (*... rewrite with ...*) + term list)) (*... assumptions*) + list); (*derivation from given term to normalform + in reverse order with sym_thm; + (#1#) could be extracted from here #1*) --------*) + +datatype istate = (*interpreter state*) + Uistate (*undefined in modspec, in '_deriv'ation*) + | ScrState of scrstate (*for script interpreter*) + | RrlsState of rrlsstate; (*for reverse rewriting*) +val e_istate = (ScrState ([],[],NONE,e_term,Sundef,false)):istate; + +type iist = istate option * istate option; +(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*) + + +fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^ + (terms2str a)^"))"; +fun istate2str Uistate = "Uistate" + | istate2str (ScrState (e,l,to,t,s,b):istate) = + "ScrState ("^ subst2str e ^",\n "^ + loc_2str l ^", "^ termopt2str to ^",\n "^ + term2str t ^", "^ safe2str s ^", "^ bool2str b ^")" + | istate2str (RrlsState (t,t1,rss,rtas)) = + "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^ + ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^ + ((strs2str o (map rta2str)) rtas)^")"; +fun istates2str (NONE, NONE) = "(#NONE, #NONE)" + | istates2str (NONE, SOME ist) = "(#NONE,\n#SOME "^istate2str ist^")" + | istates2str (SOME ist, NONE) = "(#SOME "^istate2str ist^",\n #NONE)" + | istates2str (SOME i1, SOME i2) = "(#SOME "^istate2str i1^",\n #SOME "^ + istate2str i2^")"; + +fun new_val v (ScrState (env, loc_, topt, _, safe, bool)) = + (ScrState (env, loc_, topt, v, safe, bool)) + | new_val _ _ = raise error "new_val: only for ScrState"; + +datatype con = land | lor; + + +type spec = + domID * (*WN.12.03: is replaced by thy from get_met ?FIXME? in: + specify (Init_Proof..), nxt_specify_init_calc, + assod (.SubProblem...), stac2tac (.SubProblem...)*) + pblID * + metID; +fun spec2str ((dom,pbl,met)(*:spec*)) = + "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^ + ", " ^ (strs2str met) ^ ")"; +(*> spec2str empty_spec; +val it = "(\"\", [], (\"\", \"\"))" : string *) +val empty_spec = (e_domID,e_pblID,e_metID):spec; +val e_spec = empty_spec; + + + +(*.tactics propagate the construction of the calc-tree; + there are + (a) 'specsteps' for the specify-phase, and others for the solve-phase + (b) those of the solve-phase are 'initac's and others; + initacs start with a formula different from the preceding formula. + see 'type tac_' for the internal representation of tactics.*) +datatype tac = + Init_Proof of ((cterm' list) * spec) +(*'specsteps'...*) +| Model_Problem +| Refine_Problem of pblID | Refine_Tacitly of pblID + +| Add_Given of cterm' | Del_Given of cterm' +| Add_Find of cterm' | Del_Find of cterm' +| Add_Relation of cterm' | Del_Relation of cterm' + +| Specify_Theory of domID | Specify_Problem of pblID +| Specify_Method of metID +(*...'specsteps'*) +| Apply_Method of metID +(*.creates an 'istate' in PblObj.env; in case of 'init_form' + creates a formula at ((lev_on o lev_dn) p, Frm) and in this ppobj.'loc' + 'SOME istate' (at fst of 'loc'). + As each step (in the solve-phase) has a resulting formula (at the front-end) + Apply_Method also does the 1st step in the script (an 'initac') if there + is no 'init_form' .*) +| Check_Postcond of pblID +| Free_Solve + +| Rewrite_Inst of ( subs * thm') | Rewrite of thm' + | Rewrite_Asm of thm' +| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls' +| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls' +| End_Detail (*end of script from next_tac, + in solve: switches back to parent script WN0509 drop!*) +| Derive of rls' (*an input formula using rls WN0509 drop!*) +| Calculate of string (* plus | minus | times | cancel | pow | sqrt *) +| End_Ruleset +| Substitute of sube | Apply_Assumption of cterm' list + +| Take of cterm' (*an 'initac'*) +| Take_Inst of cterm' +| Group of (con * int list ) +| Subproblem of (domID * pblID) (*an 'initac'*) +| CAScmd of cterm' (*6.6.02 URD: Function formula; WN0509 drop!*) +| End_Subproblem (*WN0509 drop!*) + +| Split_And | Conclude_And +| Split_Or | Conclude_Or +| Begin_Trans | End_Trans +| Begin_Sequ | End_Sequ(* substitute root.env *) +| Split_Intersect | End_Intersect +| Check_elementwise of cterm' | Collect_Trues +| Or_to_List + +| Empty_Tac (*TODO.11.6.03 ... of string: could carry msg of (Notappl msg) + in 'helpless'*) +| Tac of string(* eg.'repeat'*WN0509 drop!*) +| User (*internal, for ets*WN0509 drop!*) +| End_Proof';(* inout*) + +(* tac2str /--> library.sml: needed in dialog.sml for 'separable *) +fun tac2str (ma:tac) = case ma of + Init_Proof (ppc, spec) => + "Init_Proof "^(pair2str (strs2str ppc, spec2str spec)) + | Model_Problem => "Model_Problem " + | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID) + | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID) + | Add_Given cterm' => "Add_Given "^cterm' + | Del_Given cterm' => "Del_Given "^cterm' + | Add_Find cterm' => "Add_Find "^cterm' + | Del_Find cterm' => "Del_Find "^cterm' + | Add_Relation cterm' => "Add_Relation "^cterm' + | Del_Relation cterm' => "Del_Relation "^cterm' + + | Specify_Theory domID => "Specify_Theory "^(quote domID ) + | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID ) + | Specify_Method metID => "Specify_Method "^(strs2str metID) + | Apply_Method metID => "Apply_Method "^(strs2str metID) + | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID) + | Free_Solve => "Free_Solve" + + | Rewrite_Inst (subs,thm')=> + "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm')) + | Rewrite thm' => "Rewrite "^(spair2str thm') + | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm') + | Rewrite_Set_Inst (subs, rls) => + "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls)) + | Rewrite_Set rls => "Rewrite_Set "^(quote rls ) + | Detail_Set rls => "Detail_Set "^(quote rls ) + | Detail_Set_Inst (subs, rls) => + "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls)) + | End_Detail => "End_Detail" + | Derive rls' => "Derive "^rls' + | Calculate op_ => "Calculate "^op_ + | Substitute sube => "Substitute "^sube2str sube + | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's) + + | Take cterm' => "Take "^(quote cterm' ) + | Take_Inst cterm' => "Take_Inst "^(quote cterm' ) + | Group (con, ints) => + "Group "^(pair2str (con2str con, ints2str ints)) + | Subproblem (domID, pblID) => + "Subproblem "^(pair2str (domID, strs2str pblID)) +(*| Subproblem_Full (spec, cts') => + "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*) + | End_Subproblem => "End_Subproblem" + | CAScmd cterm' => "CAScmd "^(quote cterm') + + | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm') + | Or_to_List => "Or_to_List " + | Collect_Trues => "Collect_Trues" + + | Empty_Tac => "Empty_Tac" + | Tac string => "Tac "^string + | User => "User" + | End_Proof' => "tac End_Proof'" + | _ => "tac2str not impl. for ?!"; + +fun is_rewset (Rewrite_Set_Inst _) = true + | is_rewset (Rewrite_Set _) = true + | is_rewset _ = false; +fun is_rewtac (Rewrite _) = true + | is_rewtac (Rewrite_Inst _) = true + | is_rewtac (Rewrite_Asm _) = true + | is_rewtac tac = is_rewset tac; + +fun tac2IDstr (ma:tac) = case ma of + Model_Problem => "Model_Problem" + | Refine_Tacitly pblID => "Refine_Tacitly" + | Refine_Problem pblID => "Refine_Problem" + | Add_Given cterm' => "Add_Given" + | Del_Given cterm' => "Del_Given" + | Add_Find cterm' => "Add_Find" + | Del_Find cterm' => "Del_Find" + | Add_Relation cterm' => "Add_Relation" + | Del_Relation cterm' => "Del_Relation" + + | Specify_Theory domID => "Specify_Theory" + | Specify_Problem pblID => "Specify_Problem" + | Specify_Method metID => "Specify_Method" + | Apply_Method metID => "Apply_Method" + | Check_Postcond pblID => "Check_Postcond" + | Free_Solve => "Free_Solve" + + | Rewrite_Inst (subs,thm')=> "Rewrite_Inst" + | Rewrite thm' => "Rewrite" + | Rewrite_Asm thm' => "Rewrite_Asm" + | Rewrite_Set_Inst (subs, rls) => "Rewrite_Set_Inst" + | Rewrite_Set rls => "Rewrite_Set" + | Detail_Set rls => "Detail_Set" + | Detail_Set_Inst (subs, rls) => "Detail_Set_Inst" + | Derive rls' => "Derive " + | Calculate op_ => "Calculate " + | Substitute subs => "Substitute" + | Apply_Assumption ct's => "Apply_Assumption" + + | Take cterm' => "Take" + | Take_Inst cterm' => "Take_Inst" + | Group (con, ints) => "Group" + | Subproblem (domID, pblID) => "Subproblem" + | End_Subproblem => "End_Subproblem" + | CAScmd cterm' => "CAScmd" + + | Check_elementwise cterm'=> "Check_elementwise" + | Or_to_List => "Or_to_List " + | Collect_Trues => "Collect_Trues" + + | Empty_Tac => "Empty_Tac" + | Tac string => "Tac " + | User => "User" + | End_Proof' => "End_Proof'" + | _ => "tac2str not impl. for ?!"; + +fun rls_of (Rewrite_Set_Inst (_, rls)) = rls + | rls_of (Rewrite_Set rls) = rls + | rls_of tac = raise error ("rls_of: called with tac '"^tac2IDstr tac^"'"); + +fun thm_of_rew (Rewrite_Inst (subs,(thmID,_))) = + (thmID, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)) + | thm_of_rew (Rewrite (thmID,_)) = (thmID, NONE) + | thm_of_rew (Rewrite_Asm (thmID,_)) = (thmID, NONE); + +fun rls_of_rewset (Rewrite_Set_Inst (subs,rls)) = + (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)) + | rls_of_rewset (Rewrite_Set rls) = (rls, NONE) + | rls_of_rewset (Detail_Set rls) = (rls, NONE) + | rls_of_rewset (Detail_Set_Inst (subs, rls)) = + (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)); + +fun rule2tac _ (Calc (opID, thm)) = Calculate (calID2calcID opID) + | rule2tac [] (Thm (thmID, thm)) = Rewrite (thmID, string_of_thmI thm) + | rule2tac subst (Thm (thmID, thm)) = + Rewrite_Inst (subst2subs subst, (thmID, string_of_thmI thm)) + | rule2tac [] (Rls_ rls) = Rewrite_Set (id_rls rls) + | rule2tac subst (Rls_ rls) = + Rewrite_Set_Inst (subst2subs subst, (id_rls rls)) + | rule2tac _ rule = + raise error ("rule2tac: called with '" ^ rule2str rule ^ "'"); + +type fmz_ = cterm' list; + +(*.a formalization of an example containing data + sufficient for mechanically finding the solution for the example.*) +(*FIXME.WN051014: dont store fmz = (_,spec) in the PblObj, + this is done in origin*) +type fmz = fmz_ * spec; +val e_fmz = ([],e_spec); + +(*tac_ is made from tac in applicable_in, + and carries all data necessary for generate;*) +datatype tac_ = +(* datatype tac = *) + Init_Proof' of ((cterm' list) * spec) + (* ori list !: code specify -> applicable*) +| Model_Problem' of pblID * + itm list * (*the 'untouched' pbl*) + itm list (*the casually completed met*) +| Refine_Tacitly' of pblID * (*input*) + pblID * (*the refined from applicable_in*) + domID * (*from new pbt?! filled in specify*) + metID * (*from new pbt?! filled in specify*) + itm list (*drop ! 9.03: remains [] for + Model_Problem recognizing its activation*) +| Refine_Problem' of (pblID * (itm list * (bool * Term.term) list)) + (*FIXME?040215 drop: done automatically in init_proof + Subproblem'*) +| Add_Given' of cterm' * + itm list (*updated with input in fun specify_additem*) +| Add_Find' of cterm' * + itm list (*updated with input in fun specify_additem*) +| Add_Relation' of cterm' * + itm list (*updated with input in fun specify_additem*) +| Del_Given' of cterm' | Del_Find' of cterm' | Del_Relation' of cterm' + (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*) + +| Specify_Theory' of domID +| Specify_Problem' of (pblID * (* *) + (bool * (* matches *) + (itm list * (* ppc *) + (bool * term) list))) (* preconditions *) +| Specify_Method' of metID * + ori list * (*repl. "#undef"*) + itm list (*... updated from pbl to met*) +| Apply_Method' of metID * + (term option) * (*init_form*) + istate +| Check_Postcond' of + pblID * + (term * (*returnvalue of script in solve*) + cterm' list)(*collect by get_assumptions_ in applicable_in, except if + butlast tac is Check_elementwise: take only these asms*) +| Free_Solve' + +| Rewrite_Inst' of theory' * rew_ord' * rls + * bool * subst * thm' * term * (term * term list) +| Rewrite' of theory' * rew_ord' * rls * bool * thm' * + term * (term * term list) +| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' * + term * (term * term list) +| Rewrite_Set_Inst' of theory' * bool * subst * rls * + term * (term * term list) +| Detail_Set_Inst' of theory' * bool * subst * rls * + term * (term * term list) +| Rewrite_Set' of theory' * bool * rls * term * (term * term list) +| Detail_Set' of theory' * bool * rls * term * (term * term list) +| End_Detail' of (term * (term list)) (*see End_Trans'*) +| End_Ruleset' of term +| Derive' of rls +| Calculate' of theory' * string * term * (term * thm') + (*WN.29.4.03 asm?: * term list??*) +| Substitute' of subte (*the 'substitution': terms of type bool*) + * term (*to be substituted in*) + * term (*resulting from the substitution*) +| Apply_Assumption' of term list * term + +| Take' of term | Take_Inst' of term +| Group' of (con * int list * term) +| Subproblem' of (spec * + (ori list) * (*filled in assod Subproblem'*) + term * (*-"-, headline of calc-head *) + fmz_ * + term) (*Subproblem(dom,pbl)*) +| CAScmd' of term +| End_Subproblem' of term (*???*) +| Split_And' of term | Conclude_And' of term +| Split_Or' of term | Conclude_Or' of term +| Begin_Trans' of term | End_Trans' of (term * (term list)) +| Begin_Sequ' | End_Sequ'(* substitute root.env*) +| Split_Intersect' of term | End_Intersect' of term +| Check_elementwise' of (*special case:*) + term * (*(1)the current formula: [x=1,x=...]*) + string * (*(2)the pred from Check_elementwise *) + (term * (*(3)composed from (1) and (2): {x. pred}*) + term list) (*20.5.03 assumptions*) + +| Or_to_List' of term * term (* (a | b, [a,b]) *) +| Collect_Trues' of term + +| Empty_Tac_ | Tac_ of (*for dummies*) + theory * + string * (*form*) + string * (*in Tac*) + string (*result of Tac".."*) +| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*) + +fun tac_2str ma = case ma of + Init_Proof' (ppc, spec) => + "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec)) + | Model_Problem' (pblID,_,_) => "Model_Problem' "^(strs2str pblID ) + | Refine_Tacitly'(p,prefin,domID,metID,itms)=> + "Refine_Tacitly' (" + ^(strs2str p)^", "^(strs2str prefin)^", " + ^domID^", "^(strs2str metID)^", pbl-itms)" + | Refine_Problem' ms => "Refine_Problem' ("^(*matchs2str ms*)"..."^")" +(*| Match_Problem' (pI, (ok, (itms, pre))) => + "Match_Problem' "^(spair2str (strs2str pI, + spair2str (bool2str ok, + spair2str ("itms2str_ itms", + "items2str pre"))))*) + | Add_Given' cterm' => "Add_Given' "(*^cterm'*) + | Del_Given' cterm' => "Del_Given' "(*^cterm'*) + | Add_Find' cterm' => "Add_Find' "(*^cterm'*) + | Del_Find' cterm' => "Del_Find' "(*^cterm'*) + | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*) + | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*) + + | Specify_Theory' domID => "Specify_Theory' "^(quote domID ) + | Specify_Problem' (pI, (ok, (itms, pre))) => + "Specify_Problem' "^(spair2str (strs2str pI, + spair2str (bool2str ok, + spair2str ("itms2str_ itms", + "items2str pre")))) + | Specify_Method' (pI,oris,itms) => + "Specify_Method' ("^metID2str pI^", "^oris2str oris^", )" + + | Apply_Method' (metID,_,_) => "Apply_Method' "^(strs2str metID) + | Check_Postcond' (pblID,(scval,asm)) => + "Check_Postcond' "^(spair2str(strs2str pblID, + spair2str (term2str scval, strs2str asm))) + + | Free_Solve' => "Free_Solve'" + + | Rewrite_Inst' (*subs,thm'*) _ => + "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*) + | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*) + | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*) + | Rewrite_Set_Inst' (*subs,thm'*) _ => + "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*) + | Rewrite_Set'(thy',pasm,rls',f,(f',asm)) + => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^"," + ^(Syntax.string_of_term (thy2ctxt' "Isac") f)^",("^(Syntax.string_of_term (thy2ctxt' "Isac") f') + ^","^((strs2str o (map (Syntax.string_of_term (thy2ctxt' "Isac")))) asm)^"))" + + | End_Detail' _ => "End_Detail' xxx" + | Detail_Set' _ => "Detail_Set' xxx" + | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx" + + | Derive' rls => "Derive' "^id_rls rls + | Calculate' _ => "Calculate' " + | Substitute' subs => "Substitute' "(*^(subs2str subs)*) + | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*) + + | Take' cterm' => "Take' "(*^(quote cterm' )*) + | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*) + | Group' (con, ints, _) => + "Group' "^(pair2str (con2str con, ints2str ints)) + | Subproblem' (spec, oris, _,_,pbl_form) => + "Subproblem' "(*^(pair2str (domID, strs2str ,...))*) + | End_Subproblem' _ => "End_Subproblem'" + | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*) + + | Empty_Tac_ => "Empty_Tac_" + | User' => "User'" + | Tac_ (_,form,id,result) => "Tac_ (thy,"^form^","^id^","^result^")" + | _ => "tac_2str not impl. for arg"; + +(*'executed tactics' (tac_s) with local environment etc.; + used for continuing eval script + for generate*) +type ets = + (loc_ * (* of tactic in scr, tactic (weakly) associated with tac_*) + (tac_ * (* (for generate) *) + env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready: + for handling 'parallel let'*) + env * (* with results of (ready) tacs *) + term * (* itr_arg of tactic, for upd. env at Repeat, Try*) + term * (* result value of the tac *) + safe)) + list; +val Ets = []:ets; + + +fun ets2s (l,(m,eno,env,iar,res,s)) = + "\n("^(loc_2str l)^",("^(tac_2str m)^ + ",\n ens= "^(subst2str eno)^ + ",\n env= "^(subst2str env)^ + ",\n iar= "^(Syntax.string_of_term (thy2ctxt' "Isac") iar)^ + ",\n res= "^(Syntax.string_of_term (thy2ctxt' "Isac") res)^ + ",\n "^(safe2str s)^"))"; +fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets; + + +type envp =(*9.5.03: unused, delete with field in ptree.PblObj FIXXXME*) + (int * term list) list * (*assoc-list: args of met*) + (int * rls) list * (*assoc-list: tacs already done ///15.9.00*) + (int * ets) list * (*assoc-list: tacs etc. already done*) + (string * pos) list; (*asms * from where*) +val empty_envp = ([],[],[],[]):envp; + +datatype ppobj = + PrfObj of {cell : lrd option, (*where in form tac has been applied*) + (*^^^FIXME.WN0607 rename this field*) + form : term, + tac : tac, (* also in istate*) + loc : istate option * istate option, (*for form, result +13.8.02: (NONE,NONE) <==> e_istate ! see update_loc, get_loc*) + branch: branch, + result: term * term list, + ostate: ostate} (*Complete <=> result is OK*) + | PblObj of {cell : lrd option,(*unused: meaningful only for some _Prf_Obj*) + fmz : fmz, (*from init:FIXME never use this spec;-drop*) + origin: (ori list) * (*representation from fmz+pbt + for efficiently adding items in probl, meth*) + spec * (*updated by Refine_Tacitly*) + term, (*headline of calc-head, as calculated + initially(!)*) + (*# the origin of a root-pbl is created from fmz + (thus providing help for input to the user), + # the origin of a sub-pbl is created from the argument + -list of a script-tac 'SubProblem (spec) [arg-list]' + by 'match_ags'*) + spec : spec, (*explicitly input*) + probl : itm list, (*itms explicitly input*) + meth : itm list, (*itms automatically added to copy of probl + TODO: input like to 'probl'*) + env : istate option,(*for problem with initac in script*) + loc : istate option * istate option, (*for pbl+met * result*) + branch: branch, + result: term * term list, + ostate: ostate}; (*Complete <=> result is _proven_ OK*) + +(*.this tree contains isac's calculations; TODO.WN03 rename to ctree; + the structure has been copied from an early version of Theorema(c); + it has the disadvantage, that there is no space + for the first tactic in a script generating the first formula at (p,Frm); + this trouble has been covered by 'init_form' and 'Take' so far, + but it is crucial if the first tactic in a script is eg. 'Subproblem'; + see 'type tac ', Apply_Method. +.*) +datatype ptree = + EmptyPtree + | Nd of ppobj * (ptree list); +val e_ptree = EmptyPtree; + +fun rep_prfobj (PrfObj {cell,form,tac,loc,branch,result,ostate}) = + {cell=cell,form=form,tac=tac,loc=loc,branch=branch,result=result,ostate=ostate}; +fun rep_pblobj (PblObj {cell,origin,fmz,spec,probl,meth,env, + loc,branch,result,ostate}) = + {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,meth=meth, + env=env,loc=loc,branch=branch,result=result,ostate=ostate}; +fun is_prfobj (PrfObj _) = true + | is_prfobj _ =false; +(*val is_prfobj' = get_obj is_prfobj; *) +fun is_pblobj (PblObj _) = true + | is_pblobj _ = false; +(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*) + + +exception PTREE of string; +fun nth _ [] = raise PTREE "nth _ []" + | nth 1 (x::xs) = x + | nth n (x::xs) = nth (n-1) xs; +(*> nth 2 [11,22,33]; -->> val it = 22 : int*) + +fun lev_up ([]:pos) = raise PTREE "lev_up []" + | lev_up p = (drop_last p):pos; +fun lev_on ([]:pos) = raise PTREE "lev_on []" + | lev_on pos = + let val len = length pos + in (drop_last pos) @ [(nth len pos)+1] end; +fun lev_onFrm ((p,_):pos') = (lev_on p,Frm):pos' + | lev_onFrm p = raise PTREE ("*** lev_onFrm: pos'="^(pos'2str p)); +(*040216: for inform --> embed_deriv: remains on same level*) +fun lev_back (([],_):pos') = raise PTREE "lev_on_back: called by ([],_)" + | lev_back (p,_) = + if last_elem p <= 1 then (p, Frm):pos' + else ((drop_last p) @ [(nth (length p) p) - 1], Res); +(*.increase pos by n within a level.*) +fun pos_plus 0 pos = pos + | pos_plus n ((p,Frm):pos') = pos_plus (n-1) (p, Res) + | pos_plus n ((p, _):pos') = pos_plus (n-1) (lev_on p, Res); + + + +fun lev_pred ([]:pos) = raise PTREE "lev_pred []" + | lev_pred (pos:pos) = + let val len = length pos + in ((drop_last pos) @ [(nth len pos)-1]):pos end; +(*lev_pred [1,2,3]; +val it = [1,2,2] : pos +> lev_pred [1]; +val it = [0] : pos *) + +fun lev_dn p = p @ [0]; +(*> (lev_dn o lev_on) [1,2,3]; +val it = [1,2,4,0] : pos *) +(*fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos'; WN.3.12.03: never used*) +fun lev_dnRes ((p,_):pos') = (lev_dn p, Res):pos'; + +(*4.4.00*) +fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos' + | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p')); +fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos' +fun ind ((p,_):pos') = length p; (*WN050108 deprecated in favour of lev_of*) +fun lev_of ((p,_):pos') = length p; + + +(** convert ptree to a string **) + +(* convert a pos from list to string *) +fun pr_pos ps = (space_implode "." (map string_of_int ps))^". "; +(* show hd origin or form only *) +fun pr_short (p:pos) (PblObj {origin = (ori,_,_),...}) = + ((pr_pos p) ^ " ----- pblobj -----\n") +(* ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^ + (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^ + "\n") *) + | pr_short p (PrfObj {form = form,...}) = + ((pr_pos p) ^ (term2str form) ^ "\n"); +(* +fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_,_),...}) = + ((ints2str c) ^" "^ + ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^ + (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^ + "\n") + | pr_cell p (PrfObj {cell = c, form = form,...}) = + ((ints2str c) ^" "^ (term2str form) ^ "\n"); +*) + +(* convert ptree *) +fun pr_ptree f pt = + let + fun pr_pt pfn _ EmptyPtree = "" + | pr_pt pfn ps (Nd (b, [])) = pfn ps b + | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^ + (prts pfn (ps:pos) 1 ts) + and prts pfn ps p [] = "" + | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^ + (prts pfn ps (p+1) ts) + in pr_pt f [] pt end; +(* +> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n"; +> val pt = ref EmptyPtree; +> pt:=Nd("root", + [Nd("xx1",[]), + Nd("xx2", + [Nd("xx2.1.",[]), + Nd("xx2.2.",[])]), + Nd("xx3",[])]); +> writeln (pr_ptree prfn (!pt)); +*) + + +(** access the branches of ptree **) + +fun ins_nth 1 e l = e::l + | ins_nth n e [] = raise PTREE "ins_nth n e []" + | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls); +fun repl [] _ _ = raise PTREE "repl [] _ _" + | repl (l::ls) 1 e = e::ls + | repl (l::ls) n e = l::(repl ls (n-1) e); +fun repl_app ls n e = + let val lim = 1 + length ls + in if n > lim then raise PTREE "repl_app: n > lim" + else if n = lim then ls @ [e] + else repl ls n e end; +(* +> repl [1,2,3] 2 22222; +val it = [1,22222,3] : int list +> repl_app [1,2,3,4] 5 5555; +val it = [1,2,3,4,5555] : int list +> repl_app [1,2,3] 2 22222; +val it = [1,22222,3] : int list +> repl_app [1] 2 22222 ; +val it = [1,22222] : int list +*) + + +(*.get from obj at pos by f : ppobj -> 'a.*) +fun get_obj f EmptyPtree (_:pos) = raise PTREE "get_obj f EmptyPtree" + | get_obj f (Nd (b, _)) [] = f b + | get_obj f (Nd (b, bs)) (p::ps) = +(* val (f, Nd (b, bs), (p::ps)) = (I, pt, p); + *) + let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^ + (ints2str' (p::ps))^" does not exist"); + in (get_obj f (nth p bs) (ps:pos)) + (*before WN050419: 'wrong type..' raised also if pos doesn't exist*) + handle _ => raise PTREE (*"get_obj: at pos = "^ + (ints2str' (p::ps))^" wrong type of ppobj"*) + ("get_obj: pos = "^ + (ints2str' (p::ps))^" does not exist") + end; +fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree" + | get_nd n [] = n + | get_nd (Nd (_,nds)) (pos as p::(ps:pos)) = (get_nd (nth p nds) ps) + handle _ => raise PTREE ("get_nd: not existent pos = "^(ints2str' pos)); + + +(* for use by get_obj *) +fun g_cell (PblObj {cell = c,...}) = NONE + | g_cell (PrfObj {cell = c,...}) = c;(*WN0607 hack for quick introduction of lrd + rewrite-at (thms, calcs)*) +fun g_form (PrfObj {form = f,...}) = f + | g_form (PblObj {origin=(_,_,f),...}) = f; +fun g_form' (Nd (PrfObj {form = f,...}, _)) = f + | g_form' (Nd (PblObj {origin=(_,_,f),...}, _)) = f; +(* | g_form _ = raise PTREE "g_form not for PblObj";*) +fun g_origin (PblObj {origin = ori,...}) = ori + | g_origin _ = raise PTREE "g_origin not for PrfObj"; +fun g_fmz (PblObj {fmz = f,...}) = f + | g_fmz _ = raise PTREE "g_fmz not for PrfObj"; +fun g_spec (PblObj {spec = s,...}) = s + | g_spec _ = raise PTREE "g_spec not for PrfObj"; +fun g_pbl (PblObj {probl = p,...}) = p + | g_pbl _ = raise PTREE "g_pbl not for PrfObj"; +fun g_met (PblObj {meth = p,...}) = p + | g_met _ = raise PTREE "g_met not for PrfObj"; +fun g_domID (PblObj {spec = (d,_,_),...}) = d + | g_domID _ = raise PTREE "g_metID not for PrfObj"; +fun g_metID (PblObj {spec = (_,_,m),...}) = m + | g_metID _ = raise PTREE "g_metID not for PrfObj"; +fun g_env (PblObj {env,...}) = env + | g_env _ = raise PTREE "g_env not for PrfObj"; +fun g_loc (PblObj {loc = l,...}) = l + | g_loc (PrfObj {loc = l,...}) = l; +fun g_branch (PblObj {branch = b,...}) = b + | g_branch (PrfObj {branch = b,...}) = b; +fun g_tac (PblObj {spec = (d,p,m),...}) = Apply_Method m + | g_tac (PrfObj {tac = m,...}) = m; +fun g_result (PblObj {result = r,...}) = r + | g_result (PrfObj {result = r,...}) = r; +fun g_res (PblObj {result = (r,_),...}) = r + | g_res (PrfObj {result = (r,_),...}) = r; +fun g_res' (Nd (PblObj {result = (r,_),...}, _)) = r + | g_res' (Nd (PrfObj {result = (r,_),...}, _)) = r; +fun g_ostate (PblObj {ostate = r,...}) = r + | g_ostate (PrfObj {ostate = r,...}) = r; +fun g_ostate' (Nd (PblObj {ostate = r,...}, _)) = r + | g_ostate' (Nd (PrfObj {ostate = r,...}, _)) = r; + +fun gpt_cell (Nd (PblObj {cell = c,...},_)) = NONE + | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c; + +(*in CalcTree/Subproblem an 'just_created_' model is created; + this is filled to 'untouched' by Model/Refine_Problem*) +fun just_created_ (PblObj {meth, probl, spec, ...}) = + null meth andalso null probl andalso spec = e_spec; +val e_origin = ([],e_spec,e_term): (ori list) * spec * term; + +fun just_created (pt,(p,_):pos') = + let val ppobj = get_obj I pt p + in is_pblobj ppobj andalso just_created_ ppobj end; + +(*.does the pos in the ctree exist ?.*) +fun existpt pos pt = can (get_obj I pt) pos; +(*.does the pos' in the ctree exist, ie. extra check for result in the node.*) +fun existpt' ((p,p_):pos') pt = + if can (get_obj I pt) p + then case p_ of + Res => get_obj g_ostate pt p = Complete + | _ => true + else false; + +(*.is this position appropriate for calculating intermediate steps?.*) +fun is_interpos ((_, Res):pos') = true + | is_interpos _ = false; + +fun last_onlev pt pos = not (existpt (lev_on pos) pt); + + +(*.find the position of the next parent which is a PblObj in ptree.*) +fun par_pblobj pt ([]:pos) = ([]:pos) + | par_pblobj pt p = + let fun par pt [] = [] + | par pt p = if is_pblobj (get_obj I pt p) then p + else par pt (lev_up p) + in par pt (lev_up p) end; +(* lev_up for hard_gen operating with pos = [...,0] *) + +(*.find the position and the children of the next parent which is a PblObj.*) +fun par_children (Nd (PblObj _, children)) ([]:pos) = (children, []:pos) + | par_children (pt as Nd (PblObj _, children)) p = + let fun par [] = (children, []) + | par p = let val Nd (obj, children) = get_nd pt p + in if is_pblobj obj then (children, p) else par (lev_up p) + end; + in par (lev_up p) end; + +(*.get the children of a node in ptree.*) +fun children (Nd (PblObj _, cn)) = cn + | children (Nd (PrfObj _, cn)) = cn; + + +(*.find the next parent, which is either a PblObj (return true) + or a PrfObj with tac = Detail_Set (return false).*) +(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*) +fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls) + | par_pbl_det pt p = + let fun par pt [] = (true, [], Erls) + | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls) + else case get_obj g_tac pt p of + (*Detail_Set rls' => (false, p, assoc_rls rls') + (*^^^--- before 040206 after ---vvv*) + |*)Rewrite_Set rls' => (false, p, assoc_rls rls') + | Rewrite_Set_Inst (_, rls') => + (false, p, assoc_rls rls') + | _ => par pt (lev_up p) + in par pt (lev_up p) end; + + + + +(*.get from the whole ptree by f : ppobj -> 'a.*) +fun get_all f EmptyPtree = [] + | get_all f (Nd (b, [])) = [f b] + | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs) +and get_alls f [] = [] + | get_alls f pts = flat (map (get_all f) pts); + + +(*.insert obj b into ptree at pos, ev.overwriting this pos.*) +fun insert b EmptyPtree ([]:pos) = Nd (b, []) + | insert b EmptyPtree _ = raise PTREE "insert b Empty _" + | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []" + | insert b (Nd (b', bs)) (p::[]) = + Nd (b', repl_app bs p (Nd (b,[]))) + | insert b (Nd (b', bs)) (p::ps) = + Nd (b', repl_app bs p (insert b (nth p bs) ps)); +(* +> type ppobj = string; +> writeln (pr_ptree prfn (!pt)); + val pt = ref Empty; + pt:= insert ("root":ppobj) EmptyPtree []; + pt:= insert ("xx1":ppobj) (!pt) [1]; + pt:= insert ("xx2":ppobj) (!pt) [2]; + pt:= insert ("xx3":ppobj) (!pt) [3]; + pt:= insert ("xx2.1":ppobj) (!pt) [2,1]; + pt:= insert ("xx2.2":ppobj) (!pt) [2,2]; + pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1]; + pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2]; + pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3]; +*) + +(*.insert children to a node without children.*) +(*compare: fun insert*) +fun ins_chn _ EmptyPtree (_:pos) = raise PTREE "ins_chn: EmptyPtree" + | ins_chn ns (Nd _) [] = raise PTREE "ins_chn: pos = []" + | ins_chn ns (Nd (b, bs)) (p::[]) = + if p > length bs then raise PTREE "ins_chn: pos not existent" + else let val Nd (b', bs') = nth p bs + in if null bs' then Nd (b, repl_app bs p (Nd (b', ns))) + else raise PTREE "ins_chn: pos mustNOT be overwritten" end + | ins_chn ns (Nd (b, bs)) (p::ps) = + Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps)); + +(* print_depth 11;ins_chn;print_depth 3; ###insert#########################*); + + +(** apply f to obj at pos, f: ppobj -> ppobj **) + +fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs); +fun appl_obj f EmptyPtree [] = EmptyPtree + | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _" + | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs) + | appl_obj f (Nd (b, bs)) (p::[]) = + Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs)) + | appl_obj f (Nd (b, bs)) (p::ps) = + Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos))); + +(* for use by appl_obj *) +fun repl_form f (PrfObj {cell=c,form= _,tac=tac,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PrfObj {cell=c,form= f,tac=tac,loc=loc, + branch=branch,result=result,ostate=ostate} + | repl_form _ _ = raise PTREE "repl_form takes no PblObj"; +fun repl_pbl x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=_,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl= x, + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj"; +fun repl_met x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=_,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, + meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj"; + +fun repl_spec x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec= _,probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec= x,probl=probl, + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj"; +fun repl_domID x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(x,p,m),probl=probl, + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj"; +fun repl_pblID x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,x,m),probl=probl, + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj"; +fun repl_metID x (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,p,x),probl=probl, + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} + | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj"; + +fun repl_result l f' s (PrfObj {cell=cell,form=form,tac=tac,loc=_, + branch=branch,result = _ ,ostate = _}) = + PrfObj {cell=cell,form=form,tac=tac,loc= l, + branch=branch,result = f',ostate = s} + | repl_result l f' s (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=_, + branch=branch,result= _ ,ostate= _}) = + PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc= l, + branch=branch,result= f',ostate= s}; + +fun repl_tac x (PrfObj {cell=cell,form=form,tac= _,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PrfObj {cell=cell,form=form,tac= x,loc=loc, + branch=branch,result=result,ostate=ostate} + | repl_tac _ _ = raise PTREE "repl_tac takes no PblObj"; + +fun repl_branch b (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=loc, + branch= _,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, + meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate} + | repl_branch b (PrfObj {cell=cell,form=form,tac=tac,loc=loc, + branch= _,result=result,ostate=ostate}) = + PrfObj {cell=cell,form=form,tac=tac,loc=loc, + branch= b,result=result,ostate=ostate}; + +fun repl_env e + (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=_,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, + meth=meth,env=e,loc=loc,branch=branch, + result=result,ostate=ostate} + | repl_env _ _ = raise PTREE "repl_ets takes no PrfObj"; + +fun repl_oris oris + (PblObj {cell=cell,origin=(_,spe,hdf),fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl, + meth=meth,env=env,loc=loc,branch=branch, + result=result,ostate=ostate} + | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj"; +fun repl_orispec spe + (PblObj {cell=cell,origin=(oris,_,hdf),fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl, + meth=meth,env=env,loc=loc,branch=branch, + result=result,ostate=ostate} + | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj"; + +fun repl_loc l (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=_, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, + meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate} + | repl_loc l (PrfObj {cell=cell,form=form,tac=tac,loc=_, + branch=branch,result=result,ostate=ostate}) = + PrfObj {cell=cell,form=form,tac=tac,loc= l, + branch=branch,result=result,ostate=ostate}; +(* +fun uni__cid cell' + (PblObj {cell=cell,origin=origin,fmz=fmz, + spec=spec,probl=probl,meth=meth,env=env,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PblObj {cell=cell union cell',origin=origin,fmz=fmz,spec=spec,probl=probl, + meth=meth,env=env,loc=loc,branch=branch, + result=result,ostate=ostate} + | uni__cid cell' + (PrfObj {cell=cell,form=form,tac=tac,loc=loc, + branch=branch,result=result,ostate=ostate}) = + PrfObj {cell=cell union cell',form=form,tac=tac,loc=loc, + branch=branch,result=result,ostate=ostate}; +*) + +(*WN050219 put here for interpreting code for cut_tree below...*) +type ocalhd = + bool * (*ALL itms+preconds true*) + pos_ * (*model belongs to Problem | Method*) + term * (*header: Problem... or Cas + FIXXXME.12.03: item! for marking syntaxerrors*) + itm list * (*model: given, find, relate*) + ((bool * term) list) *(*model: preconds*) + spec; (*specification*) +val e_ocalhd = (false, Und, e_term, [e_itm], [(false, e_term)], e_spec); + +datatype ptform = + Form of term + | ModSpec of ocalhd; +val e_ptform = Form e_term; +val e_ptform' = ModSpec e_ocalhd; + + + +(*.applies (snd f) to the branches at a pos if ((fst f) b), + f : (ppobj -> bool) * (int -> ptree list -> ptree list).*) + +fun appl_branch f EmptyPtree [] = (EmptyPtree, false) + | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _" + | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []" + | appl_branch f (Nd (b, bs)) (p::[]) = + if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true) + else (Nd (b, bs), false) + | appl_branch f (Nd (b, bs)) (p::ps) = + let val (b',bool) = appl_branch f (nth p bs) ps + in (Nd (b, repl_app bs p b'), bool) end; + +(* for cut_level; appl_branch(deprecated) *) +fun test_trans (PrfObj{branch = Transitive,...}) = true + | test_trans (PblObj{branch = Transitive,...}) = true + | test_trans _ = false; + +fun is_pblobj' pt (p:pos) = + let val ppobj = get_obj I pt p + in is_pblobj ppobj end; + + +fun delete_result pt (p:pos) = + (appl_obj (repl_result (fst (get_obj g_loc pt p), NONE) + (e_term,[]) Incomplete) pt p); + +fun del_res (PblObj {cell, fmz, origin, spec, probl, meth, + env, loc=(l1,_), branch, result, ostate}) = + PblObj {cell=cell,fmz=fmz,origin=origin,spec=spec,probl=probl,meth=meth, + env=env, loc=(l1,NONE), branch=branch, result=(e_term,[]), + ostate=Incomplete} + + | del_res (PrfObj {cell, form, tac, loc=(l1,_), branch, result, ostate}) = + PrfObj {cell=cell,form=form,tac=tac, loc=(l1,NONE), branch=branch, + result=(e_term,[]), ostate=Incomplete}; + + +(* +fun update_fmz pt pos x = appl_obj (repl_fmz x) pt pos; + 1.00 not used anymore*) + +(*FIXME.WN.12.03: update_X X pos pt -> pt could be chained by o (efficiency?)*) +fun update_env pt pos x = appl_obj (repl_env x) pt pos; +fun update_domID pt pos x = appl_obj (repl_domID x) pt pos; +fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos; +fun update_metID pt pos x = appl_obj (repl_metID x) pt pos; +fun update_spec pt pos x = appl_obj (repl_spec x) pt pos; + +fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos; +fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos; + +fun update_met pt pos x = appl_obj (repl_met x) pt pos; +(*1.09.01 ---- +fun update_metppc pt pos x = + let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} = + get_obj g_met pt pos + in appl_obj (repl_met + {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x}) + pt pos end;*) +fun update_metppc pt pos x = appl_obj (repl_met x) pt pos; + +(*fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;*) + +fun update_branch pt pos x = appl_obj (repl_branch x) pt pos; +fun update_tac pt pos x = appl_obj (repl_tac x) pt pos; + +fun update_oris pt pos x = appl_obj (repl_oris x) pt pos; +fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos; + + (*done by append_* !! 3.5.02; ununsed WN050305 thus outcommented +fun update_loc pt (p,_) (ScrState ([],[],NONE, + Const ("empty",_),Sundef,false)) = + appl_obj (repl_loc (NONE,NONE)) pt p + | update_loc pt (p,Res) x = + let val (lform,_) = get_obj g_loc pt p + in appl_obj (repl_loc (lform,SOME x)) pt p end + + | update_loc pt (p,_) x = + let val (_,lres) = get_obj g_loc pt p + in appl_obj (repl_loc (SOME x,lres)) pt p end;-------------*) + +(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*) +fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p; + +(*13.8.02--------------------------- +fun get_loc EmptyPtree _ = NONE + | get_loc pt (p,Res) = + let val (lfrm,lres) = get_obj g_loc pt p + in if lres = e_istate then lfrm else lres end + | get_loc pt (p,_) = + let val (lfrm,lres) = get_obj g_loc pt p + in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*) +(*13.8.02: options, because istate is no equalitype any more*) +fun get_loc EmptyPtree _ = e_istate + | get_loc pt (p,Res) = + (case get_obj g_loc pt p of + (SOME i, NONE) => i + | (NONE , NONE) => e_istate + | (_ , SOME i) => i) + | get_loc pt (p,_) = + (case get_obj g_loc pt p of + (NONE , SOME i) => i (*13.8.02 just copied from ^^^: too liberal ?*) + | (NONE , NONE) => e_istate + | (SOME i, _) => i); +val get_istate = get_loc; (*3.5.02*) + +(*.collect the assumptions within a problem up to a certain position.*) +type asms = (term * pos) list;(*WN0502 should be (pos' * term) list + ...........===^===*) + +fun get_asm (b:pos, p:pos) (Nd (PblObj {result=(_,asm),...},_)) = + ((*writeln ("### get_asm PblObj:(b,p)= "^ + (pair2str(ints2str b, ints2str p)));*) + (map (rpair b) asm):asms) + | get_asm (b, p) (Nd (PrfObj {result=(_,asm),...}, [])) = + ((*writeln ("### get_asm PrfObj []:(b,p)= "^ + (pair2str(ints2str b, ints2str p)));*) + (map (rpair b) asm)) + | get_asm (b, p:pos) (Nd (PrfObj _, nds)) = + let (*val _= writeln ("### get_asm PrfObj nds:(b,p)= "^ + (pair2str(ints2str b, ints2str p)));*) + val levdn = + if p <> [] then (b @ [hd p]:pos, tl p:pos) + else (b @ [1], [99999]) (*_deeper_ nesting is always _before_ p*) + in gets_asm levdn 1 nds end +and gets_asm _ _ [] = [] + | gets_asm (b, p' as p::ps) i (nd::nds) = + if p < i then [] + else ((*writeln ("### gets_asm: (b,p')= "^(pair2str(ints2str b, + ints2str p')));*) + (get_asm (b @ [i], ps) nd) @ (gets_asm (b, p') (i + 1) nds)); + +fun get_assumptions_ (Nd (PblObj {result=(r,asm),...}, cn)) (([], _):pos') = + if r = e_term then gets_asm ([], [99999]) 1 cn + else map (rpair []) asm + | get_assumptions_ pt (p,p_) = + let val (cn, base) = par_children pt p + val offset = drop (length base, p) + val base' = replicate (length base) 1 + val offset' = case p_ of + Frm => let val (qs,q) = split_last offset + in qs @ [q - 1] end + | _ => offset + (*val _= writeln ("... get_assumptions: (b,o)= "^ + (pair2str(ints2str base',ints2str offset)))*) + in gets_asm (base', offset) 1 cn end; + + +(*--------- +end + +open Ptree; +----------*) + +(*pos of the formula on FE relative to the current pos, + which is the next writepos*) +fun pre_pos ([]:pos) = []:pos + | pre_pos pp = + let val (ps,p) = split_last pp + in case p of 1 => ps | n => ps @ [n-1] end; + +(*WN.20.5.03 ... but not used*) +fun posless [] (_::_) = true + | posless (_::_) [] = false + | posless (p::ps) (q::qs) = if p = q then posless ps qs else p < q; +(* posless [2,3,4] [3,4,5]; +true +> posless [2,3,4] [1,2,3]; +false +> posless [2,3] [2,3,4]; +true +> posless [2,3,4] [2,3]; +false +> posless [6] [6,5,2]; +true ++++ see Isabelle/../library.ML*) + + +(**.development for extracting an 'interval' from ptree.**) + +(*version 1 stopped 8.03 in favour of get_interval with !!!move_dn + actually used (inefficient) version with move_dn: see modspec.sml*) +local + +fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*) +fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*) +fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x; +fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x; + +fun getnd i (b,p) q (Nd (po, nds)) = + (if i <= 0 then [[b]] else []) @ + (getnds (i-1) true (b@[hdp p], tlp p) (tlq q) + (take_fromto (hdp p) (hdq q) nds)) + +and getnds _ _ _ _ [] = [] (*no children*) + | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*) + + | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*) + (getnd i ( b, p ) [99999] n1) @ + (getnd ~99999 (lev_on b,[0]) q n2) + + | getnds i _ (b,p) q [n1, n2] = (*intern, r-margin*) + (getnd i ( b,[0]) [99999] n1) @ + (getnd ~99999 (lev_on b,[0]) q n2) + + | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*) + (getnd i ( b, p ) [99999] nd) @ + (getnds ~99999 false (lev_on b,[0]) q nds) + + | getnds i _ (b,p) q (nd::(nds as _::_)) = (*intern, ...*) + (getnd i ( b,[0]) [99999] nd) @ + (getnds ~99999 false (lev_on b,[0]) q nds); +in +(*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes + where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous) +(1) the 'f' are given +(1a) by 'from' if 'f' = the respective element of 'from' (left margin) +(1b) -inifinity, if 'f' > the respective element of 'from' (internal node) +(2) the 't' ar given +(2a) by 'to' if 't' = the respective element of 'to' (right margin) +(2b) inifinity, if 't' < the respective element of 'to (internal node)' +the 'f' and 't' are set by hdp,... *) +fun get_trace pt p q = + (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q))) + (take_fromto (hdp p) (hdq q) (children pt)); +end; +(*WN0510 stoppde this development; + actually used (inefficient) version with move_dn: getFormulaeFromTo*) + + + + +fun get_somespec ((dI,pI,mI):spec) ((dI',pI',mI'):spec) = + let val domID = if dI = e_domID + then if dI' = e_domID + then raise error"pt_extract: no domID in probl,origin" + else dI' + else dI + val pblID = if pI = e_pblID + then if pI' = e_pblID + then raise error"pt_extract: no pblID in probl,origin" + else pI' + else pI + val metID = if mI = e_metID + then if pI' = e_metID + then raise error"pt_extract: no metID in probl,origin" + else mI' + else mI + in (domID, pblID, metID):spec end; +fun get_somespec' ((dI,pI,mI):spec) ((dI',pI',mI'):spec) = + let val domID = if dI = e_domID then dI' else dI + val pblID = if pI = e_pblID then pI' else pI + val metID = if mI = e_metID then mI' else mI + in (domID, pblID, metID):spec end; + +(*extract a formula or model from ptree for itms2itemppc or model2xml*) +fun preconds2str bts = + (strs2str o (map (linefeed o pair2str o + (apsnd term2str) o + (apfst bool2str)))) bts; +fun ocalhd2str ((b, p, hdf, itms, prec, spec):ocalhd) = + "("^bool2str b^", "^pos_2str p^", "^term2str hdf^ + ", "^itms2str_ (thy2ctxt' "Isac") itms^ + ", "^preconds2str prec^", \n"^spec2str spec^" )"; + + + +fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj; + + +(**.functions for the 'ptree iterator' as seen from the FE-Kernel interface.**) + +(*move one step down into existing nodes of ptree; regard TransitiveB +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~################## +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*) +(* val (Nd (c, ns), ([],p_)) = (pt, get_pos cI uI); + *) + if is_pblobj c + then case p_ of (*Frm => ([], Pbl) 1.12.03 + |*) Res => raise PTREE "move_dn: end of calculation" + | _ => if null ns (*go down from Pbl + Met*) + then raise PTREE "move_dn: solve problem not started" + else ([1], Frm) + else (case p_ of Res => raise PTREE "move_dn: end of (sub-)tree" + | _ => if null ns + then raise PTREE "move_dn: pos not existent 1" + else ([1], Frm)) + + (*iterate towards end of pos*) +(* val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ([]:pos, pt, get_pos cI uI); + val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ((P@[p]),(nth p ns),(ps, p_)); + *) + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) = + if p > length ns then raise PTREE "move_dn: pos not existent 2" + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_) +(* val (P, (Nd (c, ns)), ([p], p_)) = ((P@[p]), (nth p ns), (ps, p_)); + val (P, (Nd (c, ns)), ([p], p_)) = ([],pt,get_pos cI uI); + *) + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) + if p > length ns then raise PTREE "move_dn: pos not existent 3" + else if is_pblnd (nth p ns) then + ((*writeln("### move_dn: is_pblnd (nth p ns), P= "^ints2str' P^", \n"^ + "length ns= "^((string_of_int o length) ns)^ + ", p= "^string_of_int p^", p_= "^pos_2str p_);*) + case p_ of Res => if p = length ns + then if g_ostate c = Complete then (P, Res) + else raise PTREE (ints2str' P^" not complete") + (*FIXME here handle not-sequent-branches*) + else if g_branch c = TransitiveB + andalso (not o is_pblnd o (nth (p+1))) ns + then (P@[p+1], Res) + else (P@[p+1], if is_pblnd (nth (p+1) ns) + then Pbl else Frm) + | _ => if (null o children o (nth p)) ns (*go down from Pbl*) + then raise PTREE "move_dn: solve subproblem not started" + else (P @ [p, 1], + if (is_pblnd o hd o children o (nth p)) ns + then Pbl else Frm) + ) + (* val (P, Nd (c, ns), ([p], p_)) = ([], pt, ([1], Frm)); + *) + else case p_ of Frm => if (null o children o (nth p)) ns + (*then if g_ostate c = Complete then (P@[p],Res)*) + then if g_ostate' (nth p ns) = Complete + then (P@[p],Res) + else raise PTREE "move_dn: pos not existent 4" + else (P @ [p, 1], (*go down*) + if (is_pblnd o hd o children o (nth p)) ns + then Pbl else Frm) + | Res => if p = length ns + then + if g_ostate c = Complete then (P, Res) + else raise PTREE (ints2str' P^" not complete") + else + if g_branch c = TransitiveB + andalso (not o is_pblnd o (nth (p+1))) ns + then if (null o children o (nth (p+1))) ns + then (P@[p+1], Res) + else (P@[p+1,1], Frm)(*040221*) + else (P@[p+1], if is_pblnd (nth (p+1) ns) + then Pbl else Frm); +*) +(*.move one step down into existing nodes of ptree; skip Res = Frm.nxt; + move_dn at the end of the calc-tree raises PTREE.*) +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*) + (case p_ of + Res => raise PTREE "move_dn: end of calculation" + | _ => if null ns (*go down from Pbl + Met*) + then raise PTREE "move_dn: solve problem not started" + else ([1], Frm)) + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =(*iterate to end of pos*) + if p > length ns then raise PTREE "move_dn: pos not existent 2" + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_) + + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) + if p > length ns then raise PTREE "move_dn: pos not existent 3" + else case p_ of + Res => + if p = length ns (*last Res on this level: go a level up*) + then if g_ostate c = Complete then (P, Res) + else raise PTREE (ints2str' P^" not complete 1") + else (*go to the next Nd on this level, or down into the next Nd*) + if is_pblnd (nth (p+1) ns) then (P@[p+1], Pbl) + else + if g_res' (nth p ns) = g_form' (nth (p+1) ns) + then if (null o children o (nth (p+1))) ns + then (*take the Res if Complete*) + if g_ostate' (nth (p+1) ns) = Complete + then (P@[p+1], Res) + else raise PTREE (ints2str' (P@[p+1])^ + " not complete 2") + else (P@[p+1,1], Frm)(*go down into the next PrfObj*) + else (P@[p+1], Frm)(*take Frm: exists if the Nd exists*) + | Frm => (*go down or to the Res of this Nd*) + if (null o children o (nth p)) ns + then if g_ostate' (nth p ns) = Complete then (P @ [p], Res) + else raise PTREE (ints2str' (P @ [p])^" not complete 3") + else (P @ [p, 1], Frm) + | _ => (*is Pbl or Met*) + if (null o children o (nth p)) ns + then raise PTREE "move_dn:solve subproblem not startd" + else (P @ [p, 1], + if (is_pblnd o hd o children o (nth p)) ns + then Pbl else Frm); + + +(*.go one level down into ptree.*) +fun movelevel_dn [] (Nd (c, ns)) ([],p_) = (*root problem*) + if is_pblobj c + then if null ns + then raise PTREE "solve problem not started" + else ([1], if (is_pblnd o hd) ns then Pbl else Frm) + else raise PTREE "pos not existent 1" + + (*iterate towards end of pos*) + | movelevel_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) = + if p > length ns then raise PTREE "pos not existent 2" + else movelevel_dn (P@[p]) (nth p ns) (ps, p_) + + | movelevel_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) + if p > length ns then raise PTREE "pos not existent 3" else + case p_ of Res => + if p = length ns + then raise PTREE "no children" + else + if g_branch c = TransitiveB + then if (null o children o (nth (p+1))) ns + then raise PTREE "no children" + else (P @ [p+1, 1], + if (is_pblnd o hd o children o (nth (p+1))) ns + then Pbl else Frm) + else if (null o children o (nth p)) ns + then raise PTREE "no children" + else (P @ [p, 1], if (is_pblnd o hd o children o (nth p)) ns + then Pbl else Frm) + | _ => if (null o children o (nth p)) ns + then raise PTREE "no children" + else (P @ [p, 1], (*go down*) + if (is_pblnd o hd o children o (nth p)) ns + then Pbl else Frm); + + + +(*.go to the previous position in ptree; regard TransitiveB.*) +fun move_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*) + if is_pblobj c + then case p_ of Res => if null ns then ([], Pbl) (*Res -> Pbl (not Met)!*) + else ([length ns], Res) + | _ => raise PTREE "begin of calculation" + else raise PTREE "pos not existent" + + | move_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = (*iterate to end of pos*) + if p > length ns then raise PTREE "pos not existent" + else move_up (P@[p]) (nth p ns) (ps,p_) + + | move_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) + if p > length ns then raise PTREE "pos not existent" + else if is_pblnd (nth p ns) then + case p_ of Res => + let val nc = (length o children o (nth p)) ns + in if nc = 0 then (P@[p], Pbl) (*Res -> Pbl (not Met)!*) + else (P @ [p, nc], Res) end (*go down*) + | _ => if p = 1 then (P, Pbl) else (P@[p-1], Res) + else case p_ of Frm => if p <> 1 then (P, Frm) + else if is_pblobj c then (P, Pbl) else (P, Frm) + | Res => + let val nc = (length o children o (nth p)) ns + in if nc = 0 (*cannot go down*) + then if g_branch c = TransitiveB andalso p <> 1 + then (P@[p-1], Res) else (P@[p], Frm) + else (P @ [p, nc], Res) end; (*go down*) + + + +(*.go one level up in ptree; sets the position on Frm.*) +fun movelevel_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*) + raise PTREE "pos not existent" + + (*iterate towards end of pos*) + | movelevel_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = + if p > length ns then raise PTREE "pos not existent" + else movelevel_up (P@[p]) (nth p ns) (ps,p_) + + | movelevel_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) + if p > length ns then raise PTREE "pos not existent" + else if is_pblobj c then (P, Pbl) else (P, Frm); + + +(*.go to the next calc-head up in the calc-tree.*) +fun movecalchd_up pt ((p, Res):pos') = + (par_pblobj pt p, Pbl):pos' + | movecalchd_up pt (p, _) = + if is_pblobj (get_obj I pt p) + then (p, Pbl) else (par_pblobj pt p, Pbl); + +(*.determine the previous pos' on the same level.*) +(*WN0502 made for interSteps; _only_ works for branch TransitiveB*) +fun lev_pred' pt (pos:pos' as ([],Res)) = ([],Pbl):pos' + | lev_pred' pt (pos:pos' as (p, Res)) = + let val (p', last) = split_last p + in if last = 1 + then if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm) + else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p + then (p' @ [last - 1], Res) (*TransitiveB*) + else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm) + end; + +(*.determine the next pos' on the same level.*) +fun lev_on' pt (([],Pbl):pos') = ([],Res):pos' + | lev_on' pt (p, Res) = + if get_obj g_res pt p = get_obj g_form pt (lev_on p)(*TransitiveB*) + then if existpt' (lev_on p, Res) pt then (lev_on p, Res) + else raise error ("lev_on': (p, Res) -> (p, Res) not existent, \ + \p = "^ints2str' (lev_on p)) + else (lev_on p, Frm) + | lev_on' pt (p, _) = + if existpt' (p, Res) pt then (p, Res) + else raise error ("lev_on': (p, Frm) -> (p, Res) not existent, \ + \p = "^ints2str' p); + +fun exist_lev_on' pt p = (lev_on' pt p; true) handle _ => false; + +(*.is the pos' at the last element of a calulation _AND_ can be continued.*) +(* val (pt, pos as (p,p_)) = (pt, ([1],Frm)); + *) +fun is_curr_endof_calc pt (([],Res) : pos') = false + | is_curr_endof_calc pt (pos as (p,_)) = + not (exist_lev_on' pt pos) + andalso get_obj g_ostate pt (lev_up p) = Incomplete; + + +(**.insert into ctree and cut branches accordingly.**) + +(*.get all positions of certain intervals on the ctree.*) +(*OLD VERSION without move_dn; kept for occasional redesign + get all pos's to be cut in a ptree + below a pos or from a ptree list after i-th element (NO level_up).*) +fun get_allpos' (_:pos, _:posel) EmptyPtree = ([]:pos' list) + | get_allpos' (p, 1) (Nd (b, bs)) = (*p is pos of Nd*) + if g_ostate b = Incomplete + then ((*writeln("get_allpos' (p, 1) Incomplete: p="^ints2str' p);*) + [(p,Frm)] @ (get_allpos's (p, 1) bs) + ) + else ((*writeln("get_allpos' (p, 1) else: p="^ints2str' p);*) + [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)] + ) + (*WN041020 here we assume what is presented on the worksheet ?!*) + | get_allpos' (p, i) (Nd (b, bs)) = (*p is pos of Nd*) + if length bs > 0 orelse is_pblobj b + then if g_ostate b = Incomplete + then [(p,Frm)] @ (get_allpos's (p, 1) bs) + else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)] + else + if g_ostate b = Incomplete + then [] + else [(p,Res)] +(*WN041020 here we assume what is presented on the worksheet ?!*) +and get_allpos's _ [] = [] + | get_allpos's (p, i) (pt::pts) = (*p is pos of parent-Nd*) + (get_allpos' (p@[i], i) pt) @ (get_allpos's (p, i+1) pts); + +(*.get all positions of certain intervals on the ctree.*) +(*NEW version WN050225*) + + +(*.cut branches.*) +(*before WN041019...... +val cut_branch = (test_trans, curry take): + (ppobj -> bool) * (int -> ptree list -> ptree list); +.. formlery used for ... +fun cut_tree''' _ [] = EmptyPtree + | cut_tree''' pt pos = + let val (pt',cut) = appl_branch cut_branch pt pos + in if cut andalso length pos > 1 then cut_tree''' pt' (lev_up pos) + else pt' end; +*) +(*OLD version before WN050225*) +(*WN050106 like cut_level, but deletes exactly 1 node --- for tests ONLY*) +fun cut_level_'_ (_:pos' list) (_:pos) EmptyPtree (_:pos') = + raise PTREE "cut_level_'_ Empty _" + | cut_level_'_ _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level_'_ _ []" + | cut_level_'_ cuts P (Nd (b, bs)) (p::[],p_) = + if test_trans b + then (Nd (b, drop_nth [] (p:posel, bs)), + (* ~~~~~~~~~~~*) + cuts @ + (if p_ = Frm then [(P@[p],Res)] else ([]:pos' list)) @ + (*WN041020 here we assume what is presented on the worksheet ?!*) + (get_allpos's (P, p+1) (drop_nth [] (p, bs)))) + (* ~~~~~~~~~~~*) + else (Nd (b, bs), cuts) + | cut_level_'_ cuts P (Nd (b, bs)) ((p::ps),p_) = + let val (bs',cuts') = cut_level_'_ cuts P (nth p bs) (ps, p_) + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end; + +(*before WN050219*) +fun cut_level (_:pos' list) (_:pos) EmptyPtree (_:pos') = + raise PTREE "cut_level EmptyPtree _" + | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []" + + | cut_level cuts P (Nd (b, bs)) (p::[],p_) = + if test_trans b + then (Nd (b, take (p:posel, bs)), + cuts @ + (if p_ = Frm andalso (*#*) g_ostate b = Complete + then [(P@[p],Res)] else ([]:pos' list)) @ + (*WN041020 here we assume what is presented on the worksheet ?!*) + (get_allpos's (P, p+1) (takerest (p, bs)))) + else (Nd (b, bs), cuts) + + | cut_level cuts P (Nd (b, bs)) ((p::ps),p_) = + let val (bs',cuts') = cut_level cuts P (nth p bs) (ps, p_) + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end; + +(*OLD version before WN050219, overwritten below*) +fun cut_tree _ (([],_):pos') = raise PTREE "cut_tree _ ([],_)" + | cut_tree pt (pos as ([p],_)) = + let val (pt', cuts) = cut_level ([]:pos' list) [] pt pos + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete + then [] else [([],Res)])) end + | cut_tree pt (p,p_) = + let + fun cutfn pt cuts (p,p_) = + let val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_) + val cuts'' = if get_obj g_ostate pt (lev_up p) = Incomplete + then [] else [(lev_up p, Res)] + in if length cuts' > 0 andalso length p > 1 + then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*)) + else (pt',cuts @ cuts') end + val (pt', cuts) = cutfn pt [] (p,p_) + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete + then [] else [([], Res)])) end; + + +(*########/ inserted from ctreeNEW.sml \#################################**) + +(*.get all positions in a ptree until ([],Res) or ostate=Incomplete +val get_allp = fn : + pos' list -> : accumulated, start with [] + pos -> : the offset for subtrees wrt the root + ptree -> : (sub)tree + pos' : initialization (the last pos' before ...) + -> pos' list : of positions in this (sub) tree (relative to the root) +.*) +(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos'); + val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos'); + length (children pt); + *) +fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt = + (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*) + in if nxt <> ([],Res) + then get_allp (cuts @ [nxt]) (P, nxt) pt + else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list + end) handle PTREE _ => (map (apfst (curry op@ P)) cuts); + + +(*the pts are assumed to be on the same level*) +fun get_allps (cuts: pos' list) (P:pos) [] = cuts + | get_allps cuts P (pt::pts) = + let val below = get_allp [] (P, ([], Frm)) pt + val levfrm = + if is_pblnd pt + then (P, Pbl)::below + else if last_elem P = 1 + then (P, Frm)::below + else (*Trans*) below + val levres = levfrm @ (if null below then [(P, Res)] else []) + in get_allps (cuts @ levres) (lev_on P) pts end; + + +(**.these 2 funs decide on how far cut_tree goes.**) +(*.shall the nodes _after_ the pos to be inserted at be deleted?.*) +fun test_trans (PrfObj{branch = Transitive,...}) = true + | test_trans (PrfObj{branch = NoBranch,...}) = true + | test_trans (PblObj{branch = Transitive,...}) = true + | test_trans (PblObj{branch = NoBranch,...}) = true + | test_trans _ = false; +(*.shall cutting be continued on the higher level(s)? + the Nd regarded will NOT be changed.*) +fun cutlevup (PblObj _) = false (*for tests of LK0502*) + | cutlevup _ = true; +val cutlevup = test_trans;(*WN060727 after summerterm tests.LK0502 withdrawn*) + +(*cut_bottom new sml603..608 +cut the level at the bottom of the pos (used by cappend_...) +and handle the parent in order to avoid extra case for root +fn: ptree -> : the _whole_ ptree for cut_levup + pos * posel -> : the pos after split_last + ptree -> : the parent of the Nd to be cut +return + (ptree * : the updated ptree + pos' list) * : the pos's cut + bool : cutting shall be continued on the higher level(s) +*) +fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), cutlevup b) + | cut_bottom (P:pos, p:posel) (Nd (b, bs)) = + let (*divide level into 3 parts...*) + val keep = take (p - 1, bs) + val pt' as Nd (_,bs') = nth p bs + (*^^^^^_here_ will be 'insert'ed by 'append_..'*) + val (tail, tp) = (takerest (p, bs), + if null (takerest (p, bs)) then 0 else p + 1) + val (children, cuts) = + if test_trans b + then (keep, + (if is_pblnd pt' then [(P @ [p], Pbl)] else []) + @ (get_allp [] (P @ [p], (P, Frm)) pt') + @ (get_allps [] (P @ [p+1]) tail)) + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail, + get_allp [] (P @ [p], (P, Frm)) pt') + val (pt'', cuts) = + if cutlevup b + then (Nd (del_res b, children), + cuts @ (if g_ostate b = Incomplete then [] else [(P,Res)])) + else (Nd (b, children), cuts) + (*val _= writeln("####cut_bottom (P, p)="^pos2str (P @ [p])^ + ", Nd=.............................................") + val _= show_pt pt'' + val _= writeln("####cut_bottom form='"^ + term2str (get_obj g_form pt'' [])) + val _= writeln("####cut_bottom cuts#="^string_of_int (length cuts)^ + ", cuts="^pos's2str cuts)*) + in ((pt'', cuts:pos' list), cutlevup b) end; + + +(*.go all levels from the bottom of 'pos' up to the root, + on each level compose the children of a node and accumulate the cut Nds +args + pos' list -> : for accumulation + bool -> : cutting shall be continued on the higher level(s) + ptree -> : the whole ptree for 'get_nd pt P' on each level + ptree -> : the Nd from the lower level for insertion at path + pos * posel -> : pos=path split for convenience + ptree -> : Nd the children of are under consideration on this call +returns : + ptree * pos' list : the updated parent-Nd and the pos's of the Nds cut +.*) +fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:posel) (Nd (b, bs)) = + let (*divide level into 3 parts...*) + val keep = take (p - 1, bs) + (*val pt' comes as argument from below*) + val (tail, tp) = (takerest (p, bs), + if null (takerest (p, bs)) then 0 else p + 1) + val (children, cuts') = + if clevup + then (keep @ [pt'], get_allps [] (P @ [p+1]) tail) + else (keep @ [pt'] @ tail, []) + val clevup' = if clevup then cutlevup b else false + (*the first Nd with false stops cutting on all levels above*) + val (pt'', cuts') = + if clevup' + then (Nd (del_res b, children), + cuts' @ (if g_ostate b = Incomplete then [] else [(P,Res)])) + else (Nd (b, children), cuts') + (*val _= writeln("#####cut_levup clevup= "^bool2str clevup) + val _= writeln("#####cut_levup cutlevup b= "^bool2str (cutlevup b)) + val _= writeln("#####cut_levup (P, p)="^pos2str (P @ [p])^ + ", Nd=.............................................") + val _= show_pt pt'' + val _= writeln("#####cut_levup form='"^ + term2str (get_obj g_form pt'' [])) + val _= writeln("#####cut_levup cuts#="^string_of_int (length cuts)^ + ", cuts="^pos's2str cuts)*) + in if null P then (pt'', (cuts @ cuts'):pos' list) + else let val (P, p) = split_last P + in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P) + end + end; + +(*.cut nodes after and below an inserted node in the ctree; + the cuts range is limited by the predicate 'fun cutlevup'.*) +fun cut_tree pt (pos,_) = + if not (existpt pos pt) + then (pt,[]) (*appending a formula never cuts anything*) + else let val (P, p) = split_last pos + val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P) + (* pt' is the updated parent of the Nd to cappend_..*) + in if null P then (pt', cuts) + else let val (P, p) = split_last P + in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P) + end + end; + +fun append_atomic p l f r f' s pt = + let (**val _= writeln("#@append_atomic: pos ="^pos2str p)**) + val (iss, f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac + then (*after Take*) + ((fst (get_obj g_loc pt p), SOME l), + get_obj g_form pt p) + else ((NONE, SOME l), f) + in insert (PrfObj {cell = NONE, + form = f, + tac = r, + loc = iss, + branch= NoBranch, + result= f', + ostate= s}) pt p end; + + +(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here: + detail - generate - cappend: inserted, not appended !!! + + cut decided in applicable_in !?! +*) +fun cappend_atomic pt p loc f r f' s = +(* val (pt, p, loc, f, r, f', s) = + (pt,p,l,f,Rewrite_Set_Inst (subst2subs subs',id_rls rls'), + (f',asm),Complete); + *) +((*writeln("##@cappend_atomic: pos ="^pos2str p);*) + apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm)) +); +(*TODO.WN050305 redesign the handling of istates*) +fun cappend_atomic pt p ist_res f r f' s = + if existpt p pt andalso get_obj g_tac pt p=Empty_Tac + then (*after Take: transfer Frm and respective istate*) + let val (ist_form, f) = (get_loc pt (p,Frm), + get_obj g_form pt p) + val (pt, cs) = cut_tree pt (p,Frm) + val pt = append_atomic p e_istate f r f' s pt + val pt = update_loc' pt p (SOME ist_form, SOME ist_res) + in (pt, cs) end + else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm)); + + +(* called by Take *) +fun append_form p l f pt = +((*writeln("##@append_form: pos ="^pos2str p);*) + insert (PrfObj {cell = NONE, + form = (*if existpt p pt + andalso get_obj g_tac pt p = Empty_Tac + (*distinction from 'old' (+complete!) pobjs*) + then get_obj g_form pt p else*) f, + tac = Empty_Tac, + loc = (SOME l, NONE), + branch= NoBranch, + result= (e_term,[]), + ostate= Incomplete}) pt p +); +(* val (p,loc,f) = ([1], e_istate, str2term "x + 1 = 2"); + val (p,loc,f) = (fst p, e_istate, str2term "-1 + x = 0"); + *) +fun cappend_form pt p loc f = +((*writeln("##@cappend_form: pos ="^pos2str p);*) + apfst (append_form p loc f) (cut_tree pt (p,Frm)) +); +fun cappend_form pt p loc f = +let (*val _= writeln("##@cappend_form: pos ="^pos2str p) + val _= writeln("##@cappend_form before cut_tree: loc ="^istate2str loc)*) + val (pt', cs) = cut_tree pt (p,Frm) + val pt'' = append_form p loc f pt' + (*val _= writeln("##@cappend_form after append: loc ="^ + istates2str (get_obj g_loc pt'' p))*) +in (pt'', cs) end; + + + +fun append_result pt p l f s = +((*writeln("##@append_result: pos ="^pos2str p);*) + (appl_obj (repl_result (fst (get_obj g_loc pt p), + SOME l) f s) pt p, []) +); + + +(*WN041022 deprecated, still for kbtest/diffapp.sml, /systest/root-equ.sml*) +fun append_parent p l f r b pt = + let (*val _= writeln("###append_parent: pos ="^pos2str p);*) + val (ll,f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac + then ((fst (get_obj g_loc pt p), SOME l), + get_obj g_form pt p) + else ((SOME l, NONE), f) + in insert (PrfObj + {cell = NONE, + form = f, + tac = r, + loc = ll, + branch= b, + result= (e_term,[]), + ostate= Incomplete}) pt p end; +fun cappend_parent pt p loc f r b = +((*writeln("###cappend_parent: pos ="^pos2str p);*) + apfst (append_parent p loc f r b) (cut_tree pt (p,Und)) +); + + +fun append_problem [] l fmz (strs,spec,hdf) _ = +((*writeln("###append_problem: pos = []");*) + (Nd (PblObj + {cell = NONE, + origin= (strs,spec,hdf), + fmz = fmz, + spec = empty_spec, + probl = []:itm list, + meth = []:itm list, + env = NONE, + loc = (SOME l, NONE), + branch= TransitiveB,(*FIXXXXXME.27.8.03: for equations only*) + result= (e_term,[]), + ostate= Incomplete},[])) +) + | append_problem p l fmz (strs,spec,hdf) pt = +((*writeln("###append_problem: pos ="^pos2str p);*) + insert (PblObj + {cell = NONE, + origin= (strs,spec,hdf), + fmz = fmz, + spec = empty_spec, + probl = []:itm list, + meth = []:itm list, + env = NONE, + loc = (SOME l, NONE), + branch= TransitiveB, + result= (e_term,[]), + ostate= Incomplete}) pt p +); +fun cappend_problem _ [] loc fmz ori = +((*writeln("###cappend_problem: pos = []");*) + (append_problem [] loc fmz ori EmptyPtree,[]) +) + | cappend_problem pt p loc fmz ori = +((*writeln("###cappend_problem: pos ="^pos2str p);*) + apfst (append_problem p (loc:istate) fmz ori) (cut_tree pt (p,Frm)) +); + +(*.get the theory explicitly specified for the rootpbl; + thus use this function _after_ finishing specification.*) +fun rootthy (Nd (PblObj {spec=(thyID, _, _),...}, _)) = assoc_thy thyID + | rootthy _ = raise error "rootthy"; + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/generate.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/generate.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,586 @@ +(* use"ME/generate.sml"; + use"generate.sml"; + *) + +(*.initialize istate for Detail_Set.*) +(* +fun init_istate (Rewrite_Set rls) = +(* val (Rewrite_Set rls) = (get_obj g_tac pt p); + *) + (case assoc_rls rls of + Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t)) +(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls; + *) + | Rls {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Rls {scr=Script s,...} => +(* val Rls {scr=Script s,...} = assoc_rls rls; + *) + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)) + | Seq {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Seq {srls=srls,scr=Script s,...} => + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))) + | init_istate (Rewrite_Set_Inst (subs, rls)) = +(* val (Rewrite_Set_Inst (subs, rls)) = (get_obj g_tac pt p); + *) + let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs + in case assoc_rls rls of + Rls {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Rls {scr=Script s,...} => + let val (a1, a2) = two_scr_arg s + in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end + | Seq {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") +(* val Seq {scr=Script s,...} = assoc_rls rls; + *) + | Seq {scr=Script s,...} => + let val (a1, a2) = two_scr_arg s + in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end + end; +*) +(*~~~~~~~~~~~~~~~~~~~~~~copy for dev. until del.~~~~~~~~~~~~~~~~~~~~~~~~~*) +fun init_istate (Rewrite_Set rls) t = +(* val (Rewrite_Set rls) = (get_obj g_tac pt p); + *) + (case assoc_rls rls of + Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t)) +(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls; + *) + | Rls {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Rls {scr=Script s,...} => +(* val Rls {scr=Script s,...} = assoc_rls rls; + *) + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)) + | Seq {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Seq {srls=srls,scr=Script s,...} => + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))) +(* val ((Rewrite_Set_Inst (subs, rls)), t) = ((get_obj g_tac pt p), t); + *) + | init_istate (Rewrite_Set_Inst (subs, rls)) t = + let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs + (*...we suppose the substitution of only _one_ bound variable*) + in case assoc_rls rls of + Rls {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") + | Rls {scr=Script s,...} => + let val (form, bdv) = two_scr_arg s + in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true)) + end + | Seq {scr=EmptyScr,...} => + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." + ^"use prep_rls for storing rule-sets !") +(* val Seq {scr=Script s,...} = assoc_rls rls; + *) + | Seq {scr=Script s,...} => + let val (form, bdv) = two_scr_arg s + in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true)) + end + end; + + +(*.a taci holds alle information required to build a node in the calc-tree; + a taci is assumed to be used efficiently such that the calc-tree + resulting from applying a taci need not be stored separately; + see "type calcstate".*) +(*TODO.WN0504 redesign ??? or redesign generate ?? see "fun generate" + TODO.WN0512 ? redesign this _list_: + # only used for [Apply_Method + (Take or Subproblem)], i.e. for initacs + # the latter problem may be resolved automatically if "fun autocalc" is + not any more used for the specify-phase and for changing the phases*) +type taci = + (tac * (*for comparison with input tac*) + tac_ * (*for ptree generation*) + (pos' * (*after applying tac_, for ptree generation*) + istate)); (*after applying tac_, for ptree generation*) +val e_taci = (Empty_Tac, Empty_Tac_, (e_pos', e_istate)): taci; +(* val (tac, tac_, (pos', istate))::_ = tacis'; + *) +fun taci2str ((tac, tac_, (pos', istate)):taci) = + "( "^tac2str tac^", "^tac_2str tac_^", ( "^pos'2str pos' + ^", "^istate2str istate^" ))"; +fun tacis2str tacis = (strs2str o (map (linefeed o taci2str))) tacis; + +datatype pblmet = (*%^%*) + Upblmet (*undefined*) + | Problem of pblID (*%^%*) + | Method of metID; (*%^%*) +fun pblmet2str (Problem pblID) = "Problem "^(strs2str pblID)(*%^%*) + | pblmet2str (Method metID) = "Method "^(metID2str metID);(*%^%*) + (*%^%*) (*26.6. moved to sequent.sml: fun ~~~~~~~~~; was here below*) + + +(* copy from 03.60.usecases.sml 15.11.99 *) +datatype user_cmd = + Accept | NotAccept | Example +| YourTurn | MyTurn (* internal use only 7.6.02 java-sml*) +| Rules +| DontKnow (*| HowComes | WhatFor 7.6.02 java-sml*) +| Undo (*| Back | Forward 7.6.02 java-sml*) +| EndProof | EndSession +| ActivePlus | ActiveMinus | SpeedPlus | SpeedMinus + (*Stepwidth...7.6.02 java-sml*) +| Auto | NotAuto | Details; +(* for test-print-outs *) +fun user_cmd2str Accept ="Accept" + | user_cmd2str NotAccept ="NotAccept" + | user_cmd2str Example ="Example" + | user_cmd2str MyTurn ="MyTurn" + | user_cmd2str YourTurn ="YourTurn" + | user_cmd2str Rules ="Rules" +(*| user_cmd2str HowComes ="HowComes"*) + | user_cmd2str DontKnow ="DontKnow" +(*| user_cmd2str WhatFor ="WhatFor" + | user_cmd2str Back ="Back"*) + | user_cmd2str Undo ="Undo" +(*| user_cmd2str Forward ="Forward"*) + | user_cmd2str EndProof ="EndProof" + | user_cmd2str EndSession ="EndSession" + | user_cmd2str ActivePlus = "ActivePlus" + | user_cmd2str ActiveMinus = "ActiveMinus" + | user_cmd2str SpeedPlus = "SpeedPlus" + | user_cmd2str SpeedMinus = "SpeedMinus" + | user_cmd2str Auto = "Auto" + | user_cmd2str NotAuto = "NotAuto" + | user_cmd2str Details = "Details"; + + + +(*3.5.00: TODO: foppFK eliminated in interface FE-KE !!!*) +datatype foppFK = (* in DG cases div 2 *) + EmptyFoppFK (*DG internal*) +| FormFK of cterm' +| PpcFK of cterm' ppc; +fun foppFK2str (FormFK ct') ="FormFK "^ct' + | foppFK2str (PpcFK ppc) ="PpcFK "^(ppc2str ppc) + | foppFK2str EmptyFoppFK ="EmptyFoppFK"; + + +datatype nest = Open | Closed | Nundef; +fun nest2str Open = "Open" + | nest2str Closed = "Closed" + | nest2str Nundef = "Nundef"; + +type indent = int; +datatype edit = EdUndef | Write | Protect; + (* bridge --> kernel *) + (* bridge <-> kernel *) +(* needed in dialog.sml *) (* bridge <-- kernel *) +fun edit2str EdUndef = "EdUndef" + | edit2str Write = "Write" + | edit2str Protect = "Protect"; + + +datatype inout = + New_User | End_User (*<->*) +| New_Proof | End_Proof (*<->*) +| Command of user_cmd (*-->*) +| Request of string | Message of string (*<--*) +| Error_ of string | System of string (*<--*) +| FoPpcFK of foppFK (*-->*) +| FormKF of cellID * edit * indent * nest * cterm' (*<--*) +| PpcKF of cellID * edit * indent * nest * (pblmet * item ppc) (*<--*) +| RuleFK of tac (*-->*) +| RuleKF of edit * tac (*<--*) +| RefinedKF of (pblID * ((itm list) * ((bool * term) list))) (*<--*) +| Select of tac list (*<--*) +| RefineKF of match list (*<--*) +| Speed of int (*<--*) +| Active of int (*<--*) +| Domain of domID; (*<--*) + +fun inout2str End_Proof = "End_Proof" + | inout2str (Command user_cmd) = "Command "^(user_cmd2str user_cmd) + | inout2str (Request s) = "Request "^s + | inout2str (Message s) = "Message "^s + | inout2str (Error_ s) = "Error_ "^s + | inout2str (System s) = "System "^s + | inout2str (FoPpcFK foppFK) = "FoPpcFK "^(foppFK2str foppFK) + | inout2str (FormKF (cellID, edit, indent, nest, ct')) = + "FormKF ("^(string_of_int cellID)^"," + ^(edit2str edit)^","^(string_of_int indent)^"," + ^(nest2str nest)^",(" + ^ct' ^")" + | inout2str (PpcKF (cellID, edit, indent, nest, (pm,itemppc))) = + "PpcKF ("^(string_of_int cellID)^"," + ^(edit2str edit)^","^(string_of_int indent)^"," + ^(nest2str nest)^",(" + ^(pblmet2str pm)^","^(itemppc2str itemppc)^"))" + | inout2str (RuleKF (edit,tac)) = "RuleKF "^ + pair2str(edit2str edit,tac2str tac) + | inout2str (RuleFK tac) = "RuleFK "^(tac2str tac) + | inout2str (Select tacs)= + "Select "^((strs2str' o (map tac2str)) tacs) + | inout2str (RefineKF ms) = "RefineKF "^(matchs2str ms) + | inout2str (Speed i) = "Speed "^(string_of_int i) + | inout2str (Active i) = "Active "^(string_of_int i) + | inout2str (Domain dI) = "Domain "^dI; +fun inouts2str ios = (strs2str' o (map inout2str)) ios; + +datatype mout = + Form' of inout (* packing cterm' | cterm' ppc *) +| Problems of inout (* passes specify (and solve) *) +| Error' of inout +| EmptyMout; + +fun mout2str (Form' inout) ="Form' "^(inout2str inout) + | mout2str (Error' inout) ="Error' "^(inout2str inout) + | mout2str (EmptyMout ) ="EmptyMout"; + +(*fun Form'2str (Form' )*) + + + + + +(* init pbl with ...,dsc,empty | [] *) +fun init_pbl pbt = + let + fun pbt2itm (f,(d,t)) = + ((0,[],false,f,Inc((d,[]),(e_term,[]))):itm); + in map pbt2itm pbt end; +(*take formal parameters from pbt, for transfer from pbl/met-hierarchy*) +fun init_pbl' pbt = + let + fun pbt2itm (f,(d,t)) = + ((0,[],false,f,Inc((d,[t]),(e_term,[]))):itm); + in map pbt2itm pbt end; + + +(*generate 1 ppobj in ptree*) +(*TODO.WN0501: take calcstate as an argument (see embed_derive etc.)?specify?*) +fun generate1 thy (Add_Given' (_, itmlist)) Uistate (pos as (p,p_)) pt = + (pos:pos',[],Form' (PpcKF (0,EdUndef,0,Nundef, + (Upblmet,itms2itemppc thy [][]))), + case p_ of Pbl => update_pbl pt p itmlist + | Met => update_met pt p itmlist) + | generate1 thy (Add_Find' (_, itmlist)) Uistate (pos as (p,p_)) pt = + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + case p_ of Pbl => update_pbl pt p itmlist + | Met => update_met pt p itmlist) + | generate1 thy (Add_Relation' (_, itmlist)) Uistate (pos as (p,p_)) pt = + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + case p_ of Pbl => update_pbl pt p itmlist + | Met => update_met pt p itmlist) + + | generate1 thy (Specify_Theory' domID) Uistate (pos as (p,_)) pt = + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + update_domID pt p domID) + + | generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate + (pos as (p,_)) pt = + let val pt = update_pbl pt p itms + val pt = update_pblID pt p pI + in ((p,Pbl),[], + Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + pt) end + + | generate1 thy (Specify_Method' (mID, oris, itms)) Uistate + (pos as (p,_)) pt = + let val pt = update_oris pt p oris + val pt = update_met pt p itms + val pt = update_metID pt p mID + in ((p,Met),[], + Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + pt) end + + | generate1 thy (Model_Problem' (_, itms, met)) Uistate (pos as (p,_)) pt = +(* val (itms,pos as (p,_)) = (pbl, pos); + *) + let val pt = update_pbl pt p itms + val pt = update_met pt p met + in (pos,[],Form'(PpcKF(0,EdUndef,0,Nundef, + (Upblmet,itms2itemppc thy [][]))), pt) end + + | generate1 thy (Refine_Tacitly' (pI,pIre,domID,metID,pbl)) + Uistate (pos as (p,_)) pt = + let val pt = update_pbl pt p pbl + val pt = update_orispec pt p (domID,pIre,metID) + in (pos,[], + Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), + pt) end + + | generate1 thy (Refine_Problem' (pI,_)) Uistate (pos as (p,_)) pt = + let val (dI,_,mI) = get_obj g_spec pt p + val pt = update_spec pt p (dI, pI, mI) + in (pos,[], + Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),pt) + end + + | generate1 thy (Apply_Method' (_,topt, is)) _ (pos as (p,p_)) pt = + ((*writeln("###generate1 Apply_Method': pos = "^pos'2str (p,p_)); + writeln("###generate1 Apply_Method': topt= "^termopt2str topt); + writeln("###generate1 Apply_Method': is = "^istate2str is);*) + case topt of + SOME t => + let val (pt,c) = cappend_form pt p is t + (*val _= writeln("###generate1 Apply_Method: after cappend")*) + in (pos,c, EmptyMout,pt) + end + | NONE => + (pos,[],EmptyMout,update_env pt p (SOME is))) +(* val (thy, (Take' t), l, (p,p_), pt) = + ((assoc_thy "Isac.thy"), tac_, is, pos, pt); + *) + | generate1 thy (Take' t) l (p,p_) pt = (* val (Take' t) = m; *) + let (*val _=writeln("### generate1: Take' pos="^pos'2str (p,p_));*) + val p = let val (ps,p') = split_last p(*no connex to prev.ppobj*) + in if p'=0 then ps@[1] else p end; + val (pt,c) = cappend_form pt p l t; + in ((p,Frm):pos', c, + Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), pt) end + +(* val (l, (p,p_)) = (RrlsState is, p); + + val (thy, Begin_Trans' t, l, (p,Frm), pt) = + (assoc_thy "Isac.thy", tac_, is, p, pt); + *) + | generate1 thy (Begin_Trans' t) l (p,Frm) pt = + let (* print_depth 99; + map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3; + *) + val (pt,c) = cappend_form pt p l t + (* print_depth 99; + map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3; + *) + val pt = update_branch pt p TransitiveB (*040312*) + (*replace the old PrfOjb ~~~~~*) + val p = (lev_on o lev_dn(*starts with [...,0]*)) p; + val (pt,c') = cappend_form pt p l t(*FIXME.0402 same istate ???*); + in ((p,Frm), c @ c', Form' (FormKF (~1,EdUndef,(length p), Nundef, + term2str t)), pt) end + + (* val (thy, Begin_Trans' t, l, (p,Res), pt) = + (assoc_thy "Isac.thy", tac_, is, p, pt); + *) + | generate1 thy (Begin_Trans' t) l (p ,Res) pt = + (*append after existing PrfObj _________*) + generate1 thy (Begin_Trans' t) l (lev_on p,Frm) pt + + | generate1 thy (End_Trans' tasm) l (p,p_) pt = + let val p' = lev_up p + val (pt,c) = append_result pt p' l tasm Complete; + in ((p',Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), + pt) end + + | generate1 thy (Rewrite_Inst' (_,_,_,_,subs',thm',f,(f',asm))) l (p,p_) pt = + let (*val _= writeln("###generate1 Rewrite_Inst': pos= "^pos'2str (p,p_));*) + val (pt,c) = cappend_atomic pt p l f + (Rewrite_Inst (subst2subs subs',thm')) (f',asm) Complete; + val pt = update_branch pt p TransitiveB (*040312*) + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*) + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt) end + + | generate1 thy (Rewrite' (thy',ord',rls',pa,thm',f,(f',asm))) l (p,p_) pt = + let (*val _= writeln("###generate1 Rewrite': pos= "^pos'2str (p,p_))*) + val (pt,c) = cappend_atomic pt p l f (Rewrite thm') (f',asm) Complete + val pt = update_branch pt p TransitiveB (*040312*) + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*) + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt)end + + | generate1 thy (Rewrite_Asm' all) l p pt = + generate1 thy (Rewrite' all) l p pt + + | generate1 thy (Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm))) l (p,p_) pt = +(* val (thy, Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm)), l, (p,p_), pt) = + (assoc_thy "Isac.thy", tac_, is, pos, pt); + *) + let (*val _=writeln("###generate1 Rewrite_Set_Inst': pos= "^pos'2str(p,p_))*) + val (pt,c) = cappend_atomic pt p l f + (Rewrite_Set_Inst (subst2subs subs',id_rls rls')) (f',asm) Complete + val pt = update_branch pt p TransitiveB (*040312*) + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*) + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt) end + + | generate1 thy (Detail_Set_Inst' (_,_,subs,rls,f,(f',asm))) l (p,p_) pt = + let val (pt,c) = cappend_form pt p l f + val pt = update_branch pt p TransitiveB (*040312*) + + val is = init_istate (Rewrite_Set_Inst (subst2subs subs, id_rls rls)) f + val tac_ = Apply_Method' (e_metID, SOME t, is) + val pos' = ((lev_on o lev_dn) p, Frm) + in (*implicit Take*) generate1 thy tac_ is pos' pt end + + | generate1 thy (Rewrite_Set' (_,_,rls',f,(f',asm))) l (p,p_) pt = + let (*val _= writeln("###generate1 Rewrite_Set': pos= "^pos'2str (p,p_))*) + val (pt,c) = cappend_atomic pt p l f + (Rewrite_Set (id_rls rls')) (f',asm) Complete + val pt = update_branch pt p TransitiveB (*040312*) + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*) + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt) end + + | generate1 thy (Detail_Set' (_,_,rls,f,(f',asm))) l (p,p_) pt = + let val (pt,c) = cappend_form pt p l f + val pt = update_branch pt p TransitiveB (*040312*) + + val is = init_istate (Rewrite_Set (id_rls rls)) f + val tac_ = Apply_Method' (e_metID, SOME t, is) + val pos' = ((lev_on o lev_dn) p, Frm) + in (*implicit Take*) generate1 thy tac_ is pos' pt end + + | generate1 thy (Check_Postcond' (pI,(scval,asm))) l (p,p_) pt = + let (*val _=writeln("###generate1 Check_Postcond': pos= "^pos'2str(p,p_))*) + (*val (l',_) = get_obj g_loc pt p..don't overwrite with l from subpbl*) + val (pt,c) = append_result pt p l (scval,map str2term asm) Complete + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), + Nundef, term2str scval)), pt) end + + | generate1 thy (Calculate' (thy',op_,f,(f',thm'))) l (p,p_) pt = + let val (pt,c) = cappend_atomic pt p l f (Calculate op_) (f',[]) Complete; + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt) end + + | generate1 thy (Check_elementwise' (consts,pred,(f',asm))) l (p,p_) pt = + let(*val _=writeln("###generate1 Check_elementwise': p= "^pos'2str(p,p_))*) + val (pt,c) = cappend_atomic pt p l consts + (Check_elementwise pred) (f',asm) Complete; + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), + pt) end + + | generate1 thy (Or_to_List' (ors,list)) l (p,p_) pt = + let val (pt,c) = cappend_atomic pt p l ors + Or_to_List (list,[]) Complete; + in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, term2str list)), + pt) end + + | generate1 thy (Substitute' (subte, t, t')) l (p,p_) pt = + let val (pt,c) = cappend_atomic pt p l t (Substitute (subte2sube subte)) + (t',[]) Complete; + in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, + term2str t')), pt) + end + + | generate1 thy (Tac_ (_,f,id,f')) l (p,p_) pt = + let val (pt,c) = cappend_atomic pt p l (str2term f) + (Tac id) (str2term f',[]) Complete; + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f')), pt)end + + | generate1 thy (Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, f)) + l (p,p_) pt = + let (*val _=writeln("###generate1 Subproblem': pos= "^pos'2str (p,p_))*) + val (pt,c) = cappend_problem pt p l (fmz_, (domID, pblID, metID)) + (oris, (domID, pblID, metID), hdl); + (*val pbl = init_pbl ((#ppc o get_pbt) pblID); + val pt = update_pblppc pt p pbl;--------4.9.03->Model_Problem*) + (*val _= writeln("### generate1: is([3],Frm)= "^ + (istate2str (get_istate pt ([3],Frm))));*) + val f = Syntax.string_of_term (thy2ctxt thy) f; + in ((p,Pbl), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f)), pt) end + + | generate1 thy m' _ _ _ = + raise error ("generate1: not impl.for "^(tac_2str m')) +; + + +fun generate_hard thy m' (p,p_) pt = + let + val p = case p_ of Frm => p | Res => lev_on p + | _ => raise error ("generate_hard: call by "^(pos'2str (p,p_))); + in generate1 thy m' e_istate (p,p_) pt end; + + + +(*tacis are in reverse order from nxt_solve_/specify_: last = fst to insert*) +(* val (tacis, (pt, _)) = (tacis, ptp); + + val (tacis, (pt, c, _)) = (rev tacis, (pt, [], (p, Res))); + *) +fun generate ([]: taci list) ptp = ptp + | generate tacis (pt, c, _:pos'(*!dropped!WN0504redesign generate/tacis?*))= + let val (tacis', (_, tac_, (p, is))) = split_last tacis + (* for recursion ... + (tacis', (_, tac_, (p, is))) = split_last tacis'; + *) + val (p',c',_,pt') = generate1 (assoc_thy "Isac.thy") tac_ is p pt + in generate tacis' (pt', c@c', p') end; + + + +(*. a '_deriv'ation is constructed during 'reverse rewring' by an Rrls * + * of for connecting a user-input formula with the current calc-state. * + *# It is somewhat incompatible with the rest of the math-engine: * + * (1) it is not created by a script * + * (2) thus there cannot be another user-input within a derivation * + *# It suffers particularily from the not-well-foundedness of the math-engine* + * (1) FIXME other branchtyptes than Transitive will change 'embed_deriv' * + * (2) FIXME and eventually 'compare_step' (ie. the script interpreter) * + * (3) FIXME and eventually 'lev_back' * + *# SOME improvements are evident FIXME.040215 '_deriv'ation: * + * (1) FIXME nest Rls_ in 'make_deriv' * + * (2) FIXME do the not-reversed part in 'make_deriv' by scripts -- thus * + * user-input will become possible in this part of a derivation * + * (3) FIXME do (2) only if a derivation has been found -- for efficiency, * + * while a non-derivable inform requires to step until End_Proof' * + * (4) FIXME find criteria on when _not_ to step until End_Proof' * + * (5) FIXME +.*) +(*.update pos in tacis for embedding by generate.*) +(* val + *) +fun insert_pos _ [] = [] + | insert_pos (p:pos) (((tac,tac_,(_, ist))::tacis):taci list) = + ((tac,tac_,((p, Res), ist)):taci) + ::((insert_pos (lev_on p) tacis):taci list); + +fun res_from_taci (_, Rewrite'(_,_,_,_,_,_,(res, asm)), _) = (res, asm) + | res_from_taci (_, Rewrite_Set'(_,_,_,_,(res, asm)), _) = (res, asm) + | res_from_taci (_, tac_, _) = + raise error ("res_from_taci: called with" ^ tac_2str tac_); + +(*.embed the tacis created by a '_deriv'ation; sys.form <> input.form + tacis are in order, thus are reverted for generate.*) +(* val (tacis, (pt, pos as (p, Frm))) = (tacis', ptp); + *) +fun embed_deriv (tacis:taci list) (pt, pos as (p, Frm):pos') = + (*inform at Frm: replace the whole PrfObj by a Transitive-ProfObj FIXME?0402 + and transfer the istate (from _after_ compare_deriv) from Frm to Res*) + let val (res, asm) = (res_from_taci o last_elem) tacis + val (SOME ist,_) = get_obj g_loc pt p + val form = get_obj g_form pt p + (*val p = lev_on p; ---------------only difference to (..,Res) below*) + val tacis = (Begin_Trans, Begin_Trans' form, (pos, Uistate)) + ::(insert_pos ((lev_on o lev_dn) p) tacis) + @ [(End_Trans, End_Trans' (res, asm), + (pos_plus (length tacis) (lev_dn p, Res), + new_val res ist))] + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) + val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res)) + val pt = update_tac pt p (Derive (id_rls nrls)) + (*FIXME.040216 struct.ctree*) + val pt = update_branch pt p TransitiveB + in (c, (pt, pos:pos')) end + +(* val (tacis, (pt, (p, Res))) = (tacis', ptp); + *) + | embed_deriv tacis (pt, (p, Res)) = + (*inform at Res: append a Transitive-PrfObj FIXME?0402 other branch-types ? + and transfer the istate (from _after_ compare_deriv) from Res to new Res*) + let val (res, asm) = (res_from_taci o last_elem) tacis + val (_, SOME ist) = get_obj g_loc pt p + val (f,a) = get_obj g_result pt p + val p = lev_on p(*---------------only difference to (..,Frm) above*); + val tacis = (Begin_Trans, Begin_Trans' f, ((p, Frm), Uistate)) + ::(insert_pos ((lev_on o lev_dn) p) tacis) + @ [(End_Trans, End_Trans' (res, asm), + (pos_plus (length tacis) (lev_dn p, Res), + new_val res ist))]; + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) + val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res)) + val pt = update_tac pt p (Derive (id_rls nrls)) + (*FIXME.040216 struct.ctree*) + val pt = update_branch pt p TransitiveB + in (c, (pt, pos)) end; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/inform.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/inform.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,734 @@ +(* Handle user-input during the specify- and the solve-phase. + author: Walther Neuper + 0603 + (c) due to copyright terms + +use"ME/inform.sml"; +use"inform.sml"; +*) + +signature INFORM = + sig + + type castab + type icalhd + + (* type iitem *) + datatype + iitem = + Find of cterm' list + | Given of cterm' list + | Relate of cterm' list + type imodel + val imodel2fstr : iitem list -> (string * cterm') list + + + val Isac : 'a -> theory + val appl_add' : + theory' -> + SpecifyTools.ori list -> + SpecifyTools.itm list -> + ('a * (Term.term * Term.term)) list -> + string * cterm' -> SpecifyTools.itm + (* val appl_adds : + theory' -> + SpecifyTools.ori list -> + SpecifyTools.itm list -> + (string * (Term.term * Term.term)) list -> + (string * string) list -> SpecifyTools.itm list *) + (* val cas_input : string -> ptree * ocalhd *) + (* val cas_input_ : + spec -> + (Term.term * Term.term list) list -> + pblID * SpecifyTools.itm list * metID * SpecifyTools.itm list * + (bool * Term.term) list *) + val castab : castab ref + val compare_step : + calcstate' -> Term.term -> string * calcstate' + (* val concat_deriv : + 'a * ((Term.term * Term.term) list -> Term.term * Term.term -> bool) + -> + rls -> + rule list -> + Term.term -> + Term.term -> + bool * (Term.term * rule * (Term.term * Term.term list)) list *) + val dropwhile' : (* systest/auto-inform.sml *) + ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list + (* val dtss2itm_ : + pbt_ list -> + Term.term * Term.term list -> + int list * bool * string * SpecifyTools.itm_ *) + (* val e_icalhd : icalhd *) + val eq7 : ''a * ''b -> ''a * (''b * 'c) -> bool + val equal : ''a -> ''a -> bool + (* val filter_dsc : + SpecifyTools.ori list -> SpecifyTools.itm -> SpecifyTools.ori list *) + (* val filter_sep : ('a -> bool) -> 'a list -> 'a list * 'a list *) + (* val flattup2 : 'a * ('b * 'c * 'd * 'e) -> 'a * 'b * 'c * 'd * 'e *) + (* val fstr2itm_ : + theory -> + (''a * (Term.term * Term.term)) list -> + ''a * string -> int list * bool * ''a * SpecifyTools.itm_ *) + val inform : + calcstate' -> cterm' -> string * calcstate' + val input_icalhd : ptree -> icalhd -> ptree * ocalhd + (* val is_Par : SpecifyTools.itm -> bool *) + (* val is_casinput : cterm' -> fmz -> bool *) + (* val is_e_ts : Term.term list -> bool *) + (* val itms2fstr : SpecifyTools.itm -> string * string *) + (* val mk_tacis : + rew_ord' * 'a -> + rls -> + Term.term * rule * (Term.term * Term.term list) -> + tac * tac_ * (pos' * istate) *) + val oris2itms : + 'a -> int -> SpecifyTools.ori list -> SpecifyTools.itm list + (* val par2fstr : SpecifyTools.itm -> string * cterm' *) + (* val parsitm : theory -> SpecifyTools.itm -> SpecifyTools.itm *) + val rev_deriv' : 'a * rule * ('b * 'c) -> 'b * rule * ('a * 'c) + (* val unknown_expl : + theory' -> + (string * (Term.term * Term.term)) list -> + (string * string) list -> SpecifyTools.itm list *) + end + + + + + + +(***. handle an input calc-head .***) + +(*------------------------------------------------------------------(**) +structure inform :INFORM = +struct +(**)------------------------------------------------------------------*) + +datatype iitem = + Given of cterm' list +(*Where is never input*) +| Find of cterm' list +| Relate of cterm' list; + +type imodel = iitem list; + +(*calc-head as input*) +type icalhd = + pos' * (*the position of the calc-head in the calc-tree + pos' as (p,p_) where p_ is neglected due to pos_ below*) + cterm' * (*the headline*) + imodel * (*the model (without Find) of the calc-head*) + pos_ * (*model belongs to Pbl or Met*) + spec; (*specification: domID, pblID, metID*) +val e_icalhd = (e_pos', "", [Given [""]], Pbl, e_spec): icalhd; + +fun is_casinput (hdf: cterm') ((fmz_, spec): fmz) = + hdf <> "" andalso fmz_ = [] andalso spec = e_spec; + +(*.handle an input as into an algebra system.*) +fun dtss2itm_ ppc (d, ts) = + let val (f, (d, id)) = the (find_first ((curry op= d) o + (#1: (term * term) -> term) o + (#2: pbt_ -> (term * term))) ppc) + in ([1], true, f, Cor ((d, ts), (id, ts))) end; + +fun flattup2 (a,(b,c,d,e)) = (a,b,c,d,e); + + + +(*.association list with cas-commands, for generating a complete calc-head.*) +type castab = + (term * (*cas-command, eg. 'solve'*) + (spec * (*theory, problem, method*) + + (*the function generating a kind of formalization*) + (term list -> (*the arguments of the cas-command, eg. (x+1=2, x)*) + (term * (*description of an element*) + term list) (*value of the element (always put into a list)*) + list))) (*of elements in the formalization*) + list; (*of cas-entries in the association list*) + +val castab = ref ([]: castab); + + +(*..*) +(* val (dI,pI,mI) = spec; + *) +(*fun cas_input_ ((dI,pI,mI): spec) dtss = + let val thy = assoc_thy dI + val {ppc,...} = get_pbt pI + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) + val its = add_id its_ + val pits = map flattup2 its + val (pI, mI) = if mI <> ["no_met"] then (pI, mI) + else let val SOME (pI,_) = refine_pbl thy pI pits + in (pI, (hd o #met o get_pbt) pI) end + val {ppc,pre,prls,...} = get_met mI + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) + val its = add_id its_ + val mits = map flattup2 its + val pre = check_preconds thy prls pre mits +in (pI, pits: itm list, mI, mits: itm list, pre) end;*) + +(* val (dI,pI,mI) = spec; + *) +fun cas_input_ ((dI,pI,mI): spec) dtss = + let val thy = assoc_thy dI + val {ppc,...} = get_pbt pI + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) + val its = add_id its_ + val pits = map flattup2 its + val (pI, mI) = if mI <> ["no_met"] then (pI, mI) + else case refine_pbl thy pI pits of + SOME (pI,_) => (pI, (hd o #met o get_pbt) pI) + | NONE => (pI, (hd o #met o get_pbt) pI) + val {ppc,pre,prls,...} = get_met mI + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) + val its = add_id its_ + val mits = map flattup2 its + val pre = check_preconds thy prls pre mits +in (pI, pits: itm list, mI, mits: itm list, pre) end; + + +(*.check if the input term is a CAScmd and return a ptree with + a _complete_ calchead.*) +(* val hdt = ifo; + *) +fun cas_input hdt = + let val (h,argl) = strip_comb hdt + in case assoc (!castab, h) of + NONE => NONE + (*let val (pt,_) = + cappend_problem e_ptree [] e_istate + ([], e_spec) ([], e_spec, e_term) + in (pt, (false, Pbl, e_term(*FIXXME031:'not found'*), + [], [], e_spec)) end*) + | SOME (spec as (dI,_,_), argl2dtss) => + (* val SOME (spec as (dI,_,_), argl2dtss ) = assoc (!castab, h); + *) + let val dtss = argl2dtss argl + val (pI, pits, mI, mits, pre) = cas_input_ spec dtss + val spec = (dI, pI, mI) + val (pt,_) = + cappend_problem e_ptree [] e_istate ([], e_spec) + ([], e_spec, hdt) + val pt = update_spec pt [] spec + val pt = update_pbl pt [] pits + val pt = update_met pt [] mits + in SOME (pt, (true, Met, hdt, mits, pre, spec):ocalhd) end + end; + +(*lazy evaluation for Isac.thy*) +fun Isac _ = assoc_thy "Isac.thy"; + +(*re-parse itms with a new thy and prepare for checking with ori list*) +fun parsitm dI (itm as (i,v,b,f, Cor ((d,ts),_)):itm) = +(* val itm as (i,v,b,f, Cor ((d,ts),_)) = hd probl; + *) + (let val t = (comp_dts (Isac "delay")) (d,ts); + val s = Syntax.string_of_term (thy2ctxt dI) t; + (*this ^ should raise the exn on unability of re-parsing dts*) + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) + | parsitm dI (itm as (i,v,b,f, Syn str)) = + (let val t = (term_of o the o (parse dI)) str + in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str)) + | parsitm dI (itm as (i,v,b,f, Typ str)) = + (let val t = (term_of o the o (parse dI)) str + in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str)) + | parsitm dI (itm as (i,v,_,f, Inc ((d,ts),_))) = + (let val t = (comp_dts (Isac "delay")) (d,ts); + val s = Syntax.string_of_term (thy2ctxt dI) t; + (*this ^ should raise the exn on unability of re-parsing dts*) + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) + | parsitm dI (itm as (i,v,_,f, Sup (d,ts))) = + (let val t = (comp_dts (Isac"delay" )) (d,ts); + val s = Syntax.string_of_term (thy2ctxt dI) t; + (*this ^ should raise the exn on unability of re-parsing dts*) + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) + | parsitm dI (itm as (i,v,_,f, Mis (d,t'))) = + (let val t = d $ t'; + val s = Syntax.string_of_term (thy2ctxt dI) t; + (*this ^ should raise the exn on unability of re-parsing dts*) + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) + | parsitm dI (itm as (i,v,_,f, Par _)) = + raise error ("parsitm (" ^ itm2str_ (thy2ctxt dI) itm^ + "): Par should be internal"); + +(*separate a list to a pair of elements that do NOT satisfy the predicate, + and of elements that satisfy the predicate, i.e. (false, true)*) +fun filter_sep pred xs = + let fun filt ab [] = ab + | filt (a,b) (x :: xs) = if pred x + then filt (a,b@[x]) xs + else filt (a@[x],b) xs + in filt ([],[]) xs end; +fun is_Par ((_,_,_,_,Par _):itm) = true + | is_Par _ = false; + +fun is_e_ts [] = true + | is_e_ts [Const ("List.list.Nil", _)] = true + | is_e_ts _ = false; + +(*WN.9.11.03 copied from fun appl_add (in modspec.sml)*) +(* val (sel,ct) = selct; + val (dI, oris, ppc, pbt, (sel, ct))= + (#1 (some_spec ospec spec), oris, []:itm list, + ((#ppc o get_pbt) (#2 (some_spec ospec spec))), + hd (imodel2fstr imodel)); + *) +fun appl_add' dI oris ppc pbt (sel, ct) = + let + val thy = assoc_thy dI; + in case parse thy ct of + NONE => (0,[],false,sel, Syn ct):itm + | SOME ct => (* val SOME ct = parse thy ct; + *) + (case is_known thy sel oris (term_of ct) of + (* val ("",ori'(*ts='ct'*), all) = is_known thy sel oris (term_of ct); + *) + ("",ori'(*ts='ct'*), all) => + (case is_notyet_input thy ppc all ori' pbt of + (* val ("",itm) = is_notyet_input thy ppc all ori' pbt; + *) + ("",itm) => itm + (* val (msg,xx) = is_notyet_input thy ppc all ori' pbt; + *) + | (msg,_) => raise error ("appl_add': "^msg)) + (* val (msg,(_,_,_,d,ts),all) = is_known thy sel oris (term_of ct); + *) + | (msg,(i,v,_,d,ts),_) => + if is_e_ts ts then (i,v,false, sel, Inc ((d,ts),(e_term,[]))) + else (i,v,false,sel, Sup (d,ts))) + end; + +(*.generate preliminary itm_ from a strin (with field "#Given" etc.).*) +(* val (f, str) = hd selcts; + *) +fun eq7 (f, d) (f', (d', _)) = f=f' andalso d=d'; +fun fstr2itm_ thy pbt (f, str) = + let val topt = parse thy str + in case topt of + NONE => ([], false, f, Syn str) + | SOME ct => +(* val SOME ct = parse thy str; + *) + let val (d,ts) = ((split_dts thy) o term_of) ct + val popt = find_first (eq7 (f,d)) pbt + in case popt of + NONE => ([1](*??*), true(*??*), f, Sup (d,ts)) + | SOME (f, (d, id)) => ([1], true, f, Cor ((d,ts), (id, ts))) + end + end; + + +(*.input into empty PblObj, i.e. empty fmz+origin (unknown example).*) +fun unknown_expl dI pbt selcts = + let + val thy = assoc_thy dI + val its_ = map (fstr2itm_ thy pbt) selcts (*([1],true,"#Given",Cor (...))*) + val its = add_id its_ +in (map flattup2 its): itm list end; + + + + +(*WN.11.03 for input_icalhd, ~ specify_additem for Add_Given/_Find/_Relation + appl_add': generate 1 item + appl_add' . is_known: parse, get data from oris (vats, all (elems if list)..) + appl_add' . is_notyet_input: compare with items in model already input + insert_ppc': insert this 1 item*) +(* val (dI,oris,ppc,pbt,selcts) =((#1 (some_spec ospec spec)),oris,[(*!!*)], + ((#ppc o get_pbt) (#2 (some_spec ospec spec))), + (imodel2fstr imodel)); + *) +fun appl_adds dI [] _ pbt selcts = unknown_expl dI pbt selcts + (*already present itms in model are being overwritten*) + | appl_adds dI oris ppc pbt [] = ppc + | appl_adds dI oris ppc pbt (selct::ss) = + (* val selct = (sel, string_of_cterm ct); + *) + let val itm = appl_add' dI oris ppc pbt selct; + in appl_adds dI oris (insert_ppc' itm ppc) pbt ss end; +(* val (dI, oris, ppc, pbt, selct::ss) = + (dI, pors, probl, ppc, map itms2fstr probl); + ...vvv + *) +(* val (dI, oris, ppc, pbt, (selct::ss))= + (#1 (some_spec ospec spec), oris, []:itm list, + ((#ppc o get_pbt) (#2 (some_spec ospec spec))),(imodel2fstr imodel)); + val iii = appl_adds dI oris ppc pbt (selct::ss); + writeln(itms2str_ thy iii); + + val itm = appl_add' dI oris ppc pbt selct; + val ppc = insert_ppc' itm ppc; + + val _::selct::ss = (selct::ss); + val itm = appl_add' dI oris ppc pbt selct; + val ppc = insert_ppc' itm ppc; + + val _::selct::ss = (selct::ss); + val itm = appl_add' dI oris ppc pbt selct; + val ppc = insert_ppc' itm ppc; + writeln(itms2str_ thy ppc); + + val _::selct::ss = (selct::ss); + val itm = appl_add' dI oris ppc pbt selct; + val ppc = insert_ppc' itm ppc; + *) + + +fun oris2itms _ _ ([]:ori list) = ([]:itm list) + | oris2itms pbt vat ((i,v,f,d,ts)::(os: ori list)) = + if member op = vat v + then (i,v,true,f,Cor ((d,ts),(e_term,[])))::(oris2itms pbt vat os) + else oris2itms pbt vat os; + +fun filter_dsc oris itm = + filter_out ((curry op= ((d_in o #5) (itm:itm))) o + (#4:ori -> term)) oris; + + + + +fun par2fstr ((_,_,_,f, Par s):itm) = (f, s) + | par2fstr itm = raise error ("par2fstr: called with " ^ + itm2str_ (thy2ctxt' "Isac") itm); +fun itms2fstr ((_,_,_,f, Cor ((d,ts),_)):itm) = (f, comp_dts'' (d,ts)) + | itms2fstr (_,_,_,f, Syn str) = (f, str) + | itms2fstr (_,_,_,f, Typ str) = (f, str) + | itms2fstr (_,_,_,f, Inc ((d,ts),_)) = (f, comp_dts'' (d,ts)) + | itms2fstr (_,_,_,f, Sup (d,ts)) = (f, comp_dts'' (d,ts)) + | itms2fstr (_,_,_,f, Mis (d,t)) = (f, term2str (d $ t)) + | itms2fstr (itm as (_,_,_,f, Par _)) = + raise error ("parsitm ("^itm2str_ (thy2ctxt' "Isac") itm ^ + "): Par should be internal"); + +fun imodel2fstr iitems = + let fun xxx is [] = is + | xxx is ((Given strs)::iis) = + xxx (is @ (map (pair "#Given") strs)) iis + | xxx is ((Find strs)::iis) = + xxx (is @ (map (pair "#Find") strs)) iis + | xxx is ((Relate strs)::iis) = + xxx (is @ (map (pair "#Relate") strs)) iis + in xxx [] iitems end; + +(*.input a CAS-command via a whole calchead; + dWN0602 ropped due to change of design in the front-end.*) +(*since previous calc-head _only_ has changed: + EITHER _1_ part of the specification OR some items in the model; + the hdform is left as is except in cas_input .*) +(*FIXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX___Met___XXXXXXXXXXXME.TODO.WN:11.03*) +(* val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = + (p, "xxx", empty_model, Pbl, e_spec); + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = + (p,"", [Given ["fixedValues [r=Arbfix]"], + Find ["maximum A", "valuesFor [a,b]"], + Relate ["relations [A=a*b, a/2=r*sin alpha, \ + \b/2=r*cos alpha]"]], Pbl, e_spec); + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = + (([],Pbl), "not used here", + [Given ["fixedValues [r=Arbfix]"], + Find ["maximum A", "valuesFor [a,b]"(*new input*)], + Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl, + ("DiffApp.thy", ["e_pblID"], ["e_metID"])); + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = ichd; + *) +fun input_icalhd pt (((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)):icalhd) = + let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'), + spec = sspec as (sdI,spI,smI), probl, meth,...} = + get_obj I pt p; + in if is_casinput hdf fmz then the (cas_input (str2term hdf)) + else (*hacked WN0602 ~~~ ~~~~~~~~~, ..dropped !*) + let val (pos_, pits, mits) = + if dI <> sdI + then let val its = map (parsitm (assoc_thy dI)) probl; + val (its, trms) = filter_sep is_Par its; + val pbt = (#ppc o get_pbt) (#2(some_spec ospec sspec)); + in (Pbl, appl_adds dI oris its pbt + (map par2fstr trms), meth) end else + if pI <> spI + then if pI = snd3 ospec then (Pbl, probl, meth) else + let val pbt = (#ppc o get_pbt) pI + val dI' = #1 (some_spec ospec spec) + val oris = if pI = #2 ospec then oris + else prep_ori fmz_(assoc_thy"Isac.thy") pbt; + in (Pbl, appl_adds dI' oris probl pbt + (map itms2fstr probl), meth) end else + if mI <> smI (*FIXME.WN0311: what if probl is incomplete?!*) + then let val met = (#ppc o get_met) mI + val mits = complete_metitms oris probl meth met + in if foldl and_ (true, map #3 mits) + then (Pbl, probl, mits) else (Met, probl, mits) + end else + (Pbl, appl_adds (#1 (some_spec ospec spec)) oris [(*!!!*)] + ((#ppc o get_pbt) (#2 (some_spec ospec spec))) + (imodel2fstr imodel), meth); + val pt = update_spec pt p spec; + in if pos_ = Pbl + then let val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec)) + val pre =check_preconds(assoc_thy"Isac.thy")prls where_ pits + in (update_pbl pt p pits, + (ocalhd_complete pits pre spec, + Pbl, hdf', pits, pre, spec):ocalhd) end + else let val {prls,pre,...} = get_met (#3 (some_spec ospec spec)) + val pre = check_preconds (assoc_thy"Isac.thy") prls pre mits + in (update_met pt p mits, + (ocalhd_complete mits pre spec, + Met, hdf', mits, pre, spec):ocalhd) end + end end + | input_icalhd pt ((p,_), hdf, imodel, _(*Met*), spec as (dI,pI,mI)) = + raise error "input_icalhd Met not impl."; + + +(***. handle an input formula .***) +(* +Untersuchung zur Formeleingabe (appendFormula, replaceFormla) zu einer Anregung von Alan Krempler: +Welche RICHTIGEN Formeln koennen NICHT abgeleitet werden, +wenn Abteilungen nur auf gleichem Level gesucht werden ? +WN.040216 + +Beispiele zum Equationsolver von Richard Lang aus /src/sml/kbtest/rlang.sml + +------------------------------------------------------------------------------ +"Schalk I s.87 Bsp 52a ((5*x)/(x - 2) - x/(x+2)=4)"; +------------------------------------------------------------------------------ +1. "5 * x / (x - 2) - x / (x + 2) = 4" +... +4. "12 * x + 4 * x ^^^ 2 = 4 * (-4 + x ^^^ 2)",Subproblem["normalize", "poly".. +... +4.3. "16 + 12 * x = 0", Subproblem["degree_1", "polynomial", "univariate".. +... +4.3.3. "[x = -4 / 3]")), Check_elementwise "Assumptions" +... +"[x = -4 / 3]" +------------------------------------------------------------------------------ +(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n] + +(4.1)..(4.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n] +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +"Schalk I s.87 Bsp 55b (x/(x^^^2 - 6*x+9) - 1/(x^^^2 - 3*x) =1/x)"; +------------------------------------------------------------------------------ +1. "x / (x ^^^ 2 - 6 * x + 9) - 1 / (x ^^^ 2 - 3 * x) = 1 / x" +... +4. "(3 + (-1 * x + x ^^^ 2)) * x = 1 * (9 * x + (x ^^^ 3 + -6 * x ^^^ 2))" + Subproblem["normalize", "polynomial", "univariate".. +... +4.4. "-6 * x + 5 * x ^^^ 2 = 0", Subproblem["bdv_only", "degree_2", "poly".. +... +4.4.4. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions" +4.4.5. "[x = 0, x = 6 / 5]" +... +5. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions" + "[x = 6 / 5]" +------------------------------------------------------------------------------ +(1)..(4): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite schiebt [Ableitung waere in 4.4.x] + +(4.1)..(4.4.5): keine 'richtige' Eingabe kann abgeleitet werden, die dem Ergebnis "[x = 6 / 5]" aequivalent ist [Ableitung waere in 5.] +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +"Schalk II s.56 Bsp 73b (sqrt(x+1)+sqrt(4*x+4)=sqrt(9*x+9))"; +------------------------------------------------------------------------------ +1. "sqrt (x + 1) + sqrt (4 * x + 4) = sqrt (9 * x + 9)" +... +6. "13 + 13 * x + -2 * sqrt ((4 + 4 * x) * (9 + 9 * x)) = 1 + x" + Subproblem["sq", "root", "univariate", "equation"] +... +6.6. "144 + 288 * x + 144 * x ^^^ 2 = 144 + x ^^^ 2 + 288 * x + 143 * x ^^^ 2" + Subproblem["normalize", "polynomial", "univariate", "equation"] +... +6.6.3 "0 = 0" Subproblem["degree_0", "polynomial", "univariate", "equation"] +... Or_to_List +6.6.3.2 "UniversalList" +------------------------------------------------------------------------------ +(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die eine der Wurzeln auf die andere Seite verschieb [Ableitung ware in 6.6.n] + +(6.1)..(6.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 6.6.n] +------------------------------------------------------------------------------ +*) +(*sh. comments auf 498*) + +fun equal a b = a=b; + +(*the lists contain eq-al elem-pairs at the beginning; + return first list reverted (again) - ie. in order as required subsequently*) +fun dropwhile' equal (f1::f2::fs) (i1::i2::is) = + if equal f1 i1 then + if equal f2 i2 then dropwhile' equal (f2::fs) (i2::is) + else (rev (f1::f2::fs), i1::i2::is) + else raise error "dropwhile': did not start with equal elements" + | dropwhile' equal (f::fs) [i] = + if equal f i then (rev (f::fs), [i]) + else raise error "dropwhile': did not start with equal elements" + | dropwhile' equal [f] (i::is) = + if equal f i then ([f], i::is) + else raise error "dropwhile': did not start with equal elements"; +(* + fun equal a b = a=b; + val foder = [0,1,2,3,4,5]; val ifoder = [11,12,3,4,5]; + val r_foder = rev foder; val r_ifoder = rev ifoder; + dropwhile' equal r_foder r_ifoder; +> vval it = ([0, 1, 2, 3], [3, 12, 11]) : int list * int list + + val foder = [3,4,5]; val ifoder = [11,12,3,4,5]; + val r_foder = rev foder; val r_ifoder = rev ifoder; + dropwhile' equal r_foder r_ifoder; +> val it = ([3], [3, 12, 11]) : int list * int list + + val foder = [5]; val ifoder = [11,12,3,4,5]; + val r_foder = rev foder; val r_ifoder = rev ifoder; + dropwhile' equal r_foder r_ifoder; +> val it = ([5], [5, 4, 3, 12, 11]) : int list * int list + + val foder = [10,11,12,13,14,15]; val ifoder = [11,12,3,4,5]; + val r_foder = rev foder; val r_ifoder = rev ifoder; + dropwhile' equal r_foder r_ifoder; +> *** dropwhile': did not start with equal elements*) + +(*040214: version for concat_deriv*) +fun rev_deriv' (t, r, (t', a)) = (t', sym_Thm r, (t, a)); + +fun mk_tacis ro erls (t, r as Thm _, (t', a)) = + (Rewrite (rule2thm' r), + Rewrite' ("Isac.thy", fst ro, erls, false, + rule2thm' r, t, (t', a)), + (e_pos'(*to be updated before generate tacis!!!*), Uistate)) + | mk_tacis ro erls (t, r as Rls_ rls, (t', a)) = + (Rewrite_Set (rule2rls' r), + Rewrite_Set' ("Isac.thy", false, rls, t, (t', a)), + (e_pos'(*to be updated before generate tacis!!!*), Uistate)); + +(*fo = ifo excluded already in inform*) +fun concat_deriv rew_ord erls rules fo ifo = + let fun derivat ([]:(term * rule * (term * term list)) list) = e_term + | derivat dt = (#1 o #3 o last_elem) dt + fun equal (_,_,(t1, _)) (_,_,(t2, _)) = t1=t2 + val fod = make_deriv (Isac"") erls rules (snd rew_ord) NONE fo + val ifod = make_deriv (Isac"") erls rules (snd rew_ord) NONE ifo + in case (fod, ifod) of + ([], []) => if fo = ifo then (true, []) + else (false, []) + | (fod, []) => if derivat fod = ifo + then (true, fod) (*ifo is normal form*) + else (false, []) + | ([], ifod) => if fo = derivat ifod + then (true, ((map rev_deriv') o rev) ifod) + else (false, []) + | (fod, ifod) => + if derivat fod = derivat ifod (*common normal form found*) + then let val (fod', rifod') = + dropwhile' equal (rev fod) (rev ifod) + in (true, fod' @ (map rev_deriv' rifod')) end + else (false, []) + end; +(* + val ({rew_ord, erls, rules,...}, fo, ifo) = + (rep_rls Test_simplify, str2term "x+1+ -1*2=0", str2term "-2*1+(x+1)=0"); + (writeln o trtas2str) fod'; +> [" +(x + 1 + -1 * 2 = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (x + 1) = 0, []))"," +(-1 * 2 + (x + 1) = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (1 + x) = 0, []))"," +(-1 * 2 + (1 + x) = 0, Thm ("radd_left_commute","?x + (?y + ?z) = ?y + (?x + ?z)"), (1 + (-1 * 2 + x) = 0, []))"," +(1 + (-1 * 2 + x) = 0, Thm ("#mult_Float ((~1,0), (0,0)) __ ((2,0), (0,0))","-1 * 2 = -2"), (1 + (-2 + x) = 0, []))"] +val it = () : unit + (writeln o trtas2str) (map rev_deriv' rifod'); +> [" +(1 + (-2 + x) = 0, Thm ("sym_#mult_Float ((~2,0), (0,0)) __ ((1,0), (0,0))","-2 = -2 * 1"), (1 + (-2 * 1 + x) = 0, []))"," +(1 + (-2 * 1 + x) = 0, Thm ("sym_radd_left_commute","?y + (?x + ?z) = ?x + (?y + ?z)"), (-2 * 1 + (1 + x) = 0, []))"," +(-2 * 1 + (1 + x) = 0, Thm ("sym_radd_commute","?n + ?m = ?m + ?n"), (-2 * 1 + (x + 1) = 0, []))"] +val it = () : unit +*) + + +(*.compare inform with ctree.form at current pos by nrls; + if found, embed the derivation generated during comparison + if not, let the mat-engine compute the next ctree.form.*) +(*structure copied from complete_solve + CAUTION: tacis in returned calcstate' do NOT construct resulting ptp -- + all_modspec etc. has to be inserted at Subproblem'*) +(* val (tacis, c, ptp as (pt, pos as (p,p_))) = (tacis, ptp); + val (tacis, c, ptp as (pt, pos as (p,p_))) = cs'; + + val (tacis, c, ptp as (pt, pos as (p,p_))) = ([],[],(pt, lev_back pos)); + -----rec.call: + val (tacis, c, ptp as (pt, pos as (p,p_))) = cs'; + *) +fun compare_step ((tacis, c, ptp as (pt, pos as (p,p_))): calcstate') ifo = + let val fo = case p_ of Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + | _ => e_term (*on PblObj is fo <> ifo*); + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) + val {rew_ord, erls, rules,...} = rep_rls nrls + val (found, der) = concat_deriv rew_ord erls rules fo ifo; + in if found + then let val tacis' = map (mk_tacis rew_ord erls) der; + val (c', ptp) = embed_deriv tacis' ptp; + in ("ok", (tacis (*@ tacis'?WN050408*), c @ c', ptp)) end + else + if pos = ([], Res) + then ("no derivation found", (tacis, c, ptp): calcstate') + else let val cs' as (tacis, c', ptp) = nxt_solve_ ptp; + val cs' as (tacis, c'', ptp) = + case tacis of + ((Subproblem _, _, _)::_) => + let val ptp as (pt, (p,_)) = all_modspec ptp + val mI = get_obj g_metID pt p + in nxt_solv (Apply_Method' (mI, NONE, e_istate)) + e_istate ptp end + | _ => cs'; + in compare_step (tacis, c @ c' @ c'', ptp) ifo end + end; +(* writeln (trtas2str der); + *) + +(*.handle a user-input formula, which may be a CAS-command, too. +CAS-command: + create a calchead, and do 1 step + TOOODO.WN0602 works only for the root-problem !!! +formula, which is no CAS-command: + compare iform with calc-tree.form at pos by equ_nrls and all subsequent pos; + collect all the tacs applied by the way.*) +(*structure copied from autocalc*) +(* val (cs as (_, _, (pt, pos as (p, p_))): calcstate') = cs'; + val ifo = str2term ifo; + + val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) = + (cs', encode ifo); + val ((cs as (_, _, ptp as (pt, pos as (p, p_)))), istr)=(cs', (encode ifo)); + val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) = + (([],[],(pt,p)), (encode ifo)); + *) +fun inform (cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate') istr = + case parse (assoc_thy "Isac.thy") istr of +(* val SOME ifo = parse (assoc_thy "Isac.thy") istr; + *) + SOME ifo => + let val ifo = term_of ifo + val fo = case p_ of Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + | _ => #3 (get_obj g_origin pt p) + in if fo = ifo + then ("same-formula", cs) + (*thus ctree not cut with replaceFormula!*) + else case cas_input ifo of +(* val SOME (pt, _) = cas_input ifo; + *) + SOME (pt, _) => ("ok",([],[],(pt, (p, Met)))) + | NONE => + compare_step ([],[],(pt, + (*last step re-calc in compare_step TODO*) + lev_back pos)) ifo + end + | NONE => ("syntax error in '"^istr^"'", e_calcstate'); + + +(*------------------------------------------------------------------(**) +end +open inform; +(**)------------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/mathengine.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/mathengine.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,506 @@ +(* The _functional_ mathematics engine, ie. without a state. + Input and output are Isabelle's formulae as strings. + authors: Walther Neuper 2000 + (c) due to copyright terms + +use"mathengine.sml"; +*) + +signature MATHENGINE = + sig + type nxt_ + (* datatype nxt_ = HElpless | Nexts of CalcHead.calcstate *) + type NEW + type lOc_ + (*datatype + lOc_ = + ERror of string + | UNsafe of CalcHead.calcstate' + | Updated of CalcHead.calcstate' *) + + val CalcTreeTEST : + fmz list -> + pos' * NEW * mout * (string * tac) * safe * ptree + + val TESTg_form : ptree * (int list * pos_) -> mout + val autocalc : + pos' list -> + pos' -> + (ptree * pos') * taci list -> + auto -> string * pos' list * (ptree * pos') + val detailstep : ptree -> pos' -> string * ptree * pos' + (* val e_tac_ : tac_ *) + val f2str : mout -> cterm' + (* val get_pblID : ptree * pos' -> pblID option *) + val initmatch : ptree -> pos' -> ptform + (* val loc_solve_ : + string * tac_ -> ptree * (int list * pos_) -> lOc_ *) + (* val loc_specify_ : tac_ -> ptree * pos' -> lOc_ *) + val locatetac : (*tests only*) + tac -> + ptree * (posel list * pos_) -> + string * (taci list * pos' list * (ptree * (posel list * pos_))) + val me : + tac'_ -> + pos' -> + NEW -> + ptree -> pos' * NEW * mout * tac'_ * safe * ptree + + val nxt_specify_ : ptree * (int list * pos_) -> calcstate'(*tests only*) + val set_method : metID -> ptree * pos' -> ptree * ocalhd + val set_problem : pblID -> ptree * pos' -> ptree * ocalhd + val set_theory : thyID -> ptree * pos' -> ptree * ocalhd + val step : pos' -> calcstate -> string * calcstate' + val trymatch : pblID -> ptree -> pos' -> ptform + val tryrefine : pblID -> ptree -> pos' -> ptform + end + + + +(*------------------------------------------------------------------(**) +structure MathEngine : MATHENGINE = +struct +(**)------------------------------------------------------------------*) + +fun get_pblID (pt, (p,_):pos') = + let val p' = par_pblobj pt p + val (_,pI,_) = get_obj g_spec pt p' + val (_,(_,oI,_),_) = get_obj g_origin pt p' + in if pI <> e_pblID then SOME pI + else if oI <> e_pblID then SOME oI + else NONE end; +(*fun get_pblID (pt, (p,_):pos') = + ((snd3 o (get_obj g_spec pt)) (par_pblobj pt p));*) + + +(*--vvv--dummies for test*) +val e_tac_ = Tac_ (Pure.thy,"","",""); +datatype lOc_ = + ERror of string (*after loc_specify, loc_solve*) +| UNsafe of calcstate' (*after loc_specify, loc_solve*) +| Updated of calcstate'; (*after loc_specify, loc_solve*) +fun loc_specify_ m (pt,pos) = +(* val pos = ip; + *) + let val (p,_,f,_,s,pt) = specify m pos [] pt; +(* val (_,_,_,_,_,pt')= specify m pos [] pt; + *) + in case f of + (Error' (Error_ e)) => ERror e + | _ => Updated ([], [], (pt,p)) end; + +(*. TODO push return-value cs' into solve and rename solve->loc_solve?_? .*) +(* val (m, pos) = ((mI,m), ip); + val (m,(pt,pos) ) = ((mI,m), ptp); + *) +fun loc_solve_ m (pt,pos) = + let val (msg, cs') = solve m (pt, pos); +(* val (tacis,dels,(pt',p')) = cs'; + (writeln o istate2str) (get_istate pt' p'); + (term2str o fst) (get_obj g_result pt' (fst p')); + *) + in case msg of + "ok" => Updated cs' + | msg => ERror msg + end; + +datatype nxt_ = + HElpless (**) + | Nexts of calcstate; (**) + +(*. locate a tactic in a script and apply it if possible .*) +(*report applicability of tac in tacis; pt is dropped in setNextTactic*) +fun locatetac _ (ptp as (_,([],Res))) = ("end-of-calculation", ([], [], ptp)) +(* val ptp as (pt, p) = (pt, p); + val ptp as (pt, p) = (pt, ip); + *) + | locatetac tac (ptp as (pt, p)) = + let val (mI,m) = mk_tac'_ tac; + in case applicable_in p pt m of + Notappl e => ("not-applicable", ([],[], ptp):calcstate') + | Appl m => +(* val Appl m = applicable_in p pt m; + *) + let val x = if member op = specsteps mI + then loc_specify_ m ptp else loc_solve_ (mI,m) ptp + in case x of + ERror e => ("failure", ([], [], ptp)) + (*FIXXXXXME: loc_specify_, loc_solve_ TOGETHER with dropping meOLD+detail.sml*) + | UNsafe cs' => ("unsafe-ok", cs') + | Updated (cs' as (_,_,(_,p'))) => + (*ev.SEVER.tacs like Begin_Trans*) + (if p' = ([],Res) then "end-of-calculation" else "ok", + cs')(*for -"- user to ask ? *) + end + end; + + +(*------------------------------------------------------------------ +fun init_detail ptp = e_calcstate;(*15.8.03.MISSING-->solve.sml!?*) +(*----------------------------------------------------from solve.sml*) + | nxt_solv (Detail_Set'(thy', rls, t)) (pt, p) = + let (*val rls = the (assoc(!ruleset',rls')) + handle _ => raise error ("solve: '"^rls'^"' not known");*) + val thy = assoc_thy thy'; + val (srls, sc, is) = + case rls of + Rrls {scr=sc as Rfuns {init_state=ii,...},...} => + (e_rls, sc, RrlsState (ii t)) + | Rls {srls=srls,scr=sc as Script s,...} => + (srls, sc, ScrState ([(one_scr_arg s,t)], [], + NONE, e_term, Sundef, true)); + val pt = update_tac pt (fst p) (Detail_Set (id_rls rls)); + val (p,cid,_,pt) = generate1 thy (Begin_Trans' t) is p pt; + val nx = (tac_2tac o fst3) (next_tac (thy',srls) (pt,p) sc is); + val aopt = applicable_in p pt nx; + in case aopt of + Notappl s => raise error ("solve Detail_Set: "^s) + (* val Appl m = aopt; + *) + | Appl m => solve ("discardFIXME",m) p pt end +------------------------------------------------------------------*) + + +(*iterated by nxt_me; there (the resulting) ptp dropped + may call nxt_solve Apply_Method --- thus evaluated here after solve.sml*) +(* val (ptp as (pt, pos as (p,p_))) = ptp; + val (ptp as (pt, pos as (p,p_))) = (pt,ip); + *) +fun nxt_specify_ (ptp as (pt, pos as (p,p_))) = + let val pblobj as (PblObj{meth,origin=origin as (oris,(dI',pI',mI'),_), + probl,spec=(dI,pI,mI),...}) = get_obj I pt p; + in if just_created_ pblobj (*by Subproblem*) andalso origin <> e_origin + then case mI' of + ["no_met"] => nxt_specif (Refine_Tacitly pI') (pt, (p, Pbl)) + | _ => nxt_specif Model_Problem (pt, (p,Pbl)) + else let val cpI = if pI = e_pblID then pI' else pI; + val cmI = if mI = e_metID then mI' else mI; + val {ppc,prls,where_,...} = get_pbt cpI; + val pre = check_preconds "thy 100820" prls where_ probl; + val pb = foldl and_ (true, map fst pre); + (*FIXME.WN0308: ~~~~~: just check true in itms of pbl/met?*) + val (_,tac) = + nxt_spec p_ pb oris (dI',pI',mI') (probl, meth) + (ppc, (#ppc o get_met) cmI) (dI, pI, mI); + in case tac of + Apply_Method mI => +(* val Apply_Method mI = tac; + *) + nxt_solv (Apply_Method' (mI, NONE, e_istate)) e_istate ptp + | _ => nxt_specif tac ptp end + end; + + +(*.specify a new method; + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method ' .*) +fun set_method (mI:metID) ptp = + let val ([(_, Specify_Method' (_, _, mits), _)], [], (pt, pos as (p,_))) = + nxt_specif (Specify_Method mI) ptp + val pre = [] (*...from Specify_Method'*) + val complete = true (*...from Specify_Method'*) + (*from Specify_Method' ? vvv, vvv ?*) + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p + in (pt, (complete, Met, hdf, mits, pre, spec):ocalhd) end; + +(* val ([(_, Specify_Method' (_, _, mits), _)], [],_) = + nxt_specif (Specify_Method mI) ptp; + *) + +(*.specify a new problem; + WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem ' .*) +(* val (pI, ptp) = (pI, (pt, ip)); + *) +fun set_problem pI (ptp: ptree * pos') = + let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)], + _, (pt, pos as (p,_))) = nxt_specif (Specify_Problem pI) ptp + (*from Specify_Problem' ? vvv, vvv ?*) + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p + in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end; + +fun set_theory (tI:thyID) (ptp: ptree * pos') = + let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)], + _, (pt, pos as (p,_))) = nxt_specif (Specify_Theory tI) ptp + (*from Specify_Theory' ? vvv, vvv ?*) + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p + in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end; + +(*.does a step forward; returns tactic used, ctree updated. +TODO.WN0512 redesign after specify-phase became more separated from solve-phase +arg ip: + calcstate +.*) +(* val (ip as (_,p_), (ptp as (pt,p), tacis)) = (get_pos 1 1, get_calc 1); + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (pos, cs); + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (p, ((pt, e_pos'),[])); + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (ip,cs); + *) +fun step ((ip as (_,p_)):pos') ((ptp as (pt,p), tacis):calcstate) = + let val pIopt = get_pblID (pt,ip); + in if (*p = ([],Res) orelse*) ip = ([],Res) + then ("end-of-calculation",(tacis, [], ptp):calcstate') else + case tacis of + (_::_) => +(* val((tac,_,_)::_) = tacis; + *) + if ip = p (*the request is done where ptp waits for*) + then let val (pt',c',p') = generate tacis (pt,[],p) + in ("ok", (tacis, c', (pt', p'))) end + else (case (if member op = [Pbl,Met] p_ + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip)) + handle _ => ([],[],ptp)(*e.g.by Add_Given "equality///"*) + of cs as ([],_,_) => ("helpless", cs) + | cs => ("ok", cs)) +(* val [] = tacis; + *) + | _ => (case pIopt of + NONE => ("no-fmz-spec", ([], [], ptp)) + | SOME pI => +(* val SOME pI = pIopt; + val cs=(if member op = [Pbl,Met] p_ andalso is_none(get_obj g_env pt (fst p)) + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip)) + handle _ => ([], ptp); + *) + (case (if member op = [Pbl,Met] p_ + andalso is_none (get_obj g_env pt (fst p)) + (*^^^^^^^^: Apply_Method without init_form*) + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip) ) + handle _ => ([],[],ptp)(*e.g.by Add_Giv"equality/"*) + of cs as ([],_,_) =>("helpless", cs)(*FIXXMEdel.handle*) + | cs => ("ok", cs))) + end; + +(* (nxt_solve_ (pt,ip)) handle e => print_exn e ; + + *) + + + + +(*.does several steps within one calculation as given by "type auto"; + the steps may arbitrarily go into and leave different phases, + i.e. specify-phase and solve-phase.*) +(*TODO.WN0512 ? redesign after the phases have been more separated + at the fron-end in 05: + eg. CompleteCalcHead could be done by a separate fun !!!*) +(* val (ip, cs as (ptp as (pt,p),tacis)) = (get_pos cI 1, get_calc cI); + val (ip, cs as (ptp as (pt,p),tacis)) = (pold, get_calc cI); + val (c, ip, cs as (ptp as (_,p),tacis), Step s) = + ([]:pos' list, pold, get_calc cI, auto); + *) +fun autocalc c ip (cs as (ptp as (_,p),tacis)) (Step s) = + if s <= 1 + then let val (str, (_, c', ptp)) = step ip cs;(*1*) + (*at least does 1 step, ev.1 too much*) + in (str, c@c', ptp) end + else let val (str, (_, c', ptp as (_, p))) = step ip cs; + in if str = "ok" + then autocalc (c@c') p (ptp,[]) (Step (s-1)) + else (str, c@c', ptp) end +(*handles autoord <= 3, autoord > 3 handled by all_/complete_solve*) + | autocalc c (pos as (_,p_)) ((pt,_), _(*tacis would help 1x in solve*))auto= +(* val (c:pos' list, (pos as (_,p_)),((pt,_),_),auto) = + ([], pold, get_calc cI, auto); + *) + if autoord auto > 3 andalso just_created (pt, pos) + then let val ptp = all_modspec (pt, pos); + in all_solve auto c ptp end + else + if member op = [Pbl, Met] p_ + then if not (is_complete_mod (pt, pos)) + then let val ptp = complete_mod (pt, pos) + in if autoord auto < 3 then ("ok", c, ptp) + else + if not (is_complete_spec ptp) + then let val ptp = complete_spec ptp + in if autoord auto = 3 then ("ok", c, ptp) + else all_solve auto c ptp + end + else if autoord auto = 3 then ("ok", c, ptp) + else all_solve auto c ptp + end + else + if not (is_complete_spec (pt,pos)) + then let val ptp = complete_spec (pt, pos) + in if autoord auto = 3 then ("ok", c, ptp) + else all_solve auto c ptp + end + else if autoord auto = 3 then ("ok", c, (pt, pos)) + else all_solve auto c (pt, pos) + else complete_solve auto c (pt, pos); +(* val pbl = get_obj g_pbl (fst ptp) []; + val (oris,_,_) = get_obj g_origin (fst ptp) []; +*) + + + + + +(*.initialiye matching; before 'tryMatch' get the pblID to match with: + if no pbl has been specified, take the init from origin.*) +(*fun initmatch pt (pos as (p,_):pos') = + let val PblObj {probl,origin=(os,(_,pI,_),_),spec=(dI',pI',mI'),...} = + get_obj I pt p + val pblID = if pI' = e_pblID + then (*TODO.WN051125 (#init o get_pbt) pI <<<*) + takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*) + else pI' + val spec = (dI',pblID,mI') + val {ppc,where_,prls,...} = get_pbt pblID + val (model_ok, (pbl, pre)) = + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os + in ModSpec (ocalhd_complete pbl pre spec, + Pbl, e_term, pbl, pre, spec) end;*) +fun initcontext_pbl pt (pos as (p,_):pos') = + let val PblObj {probl,origin=(os,(_,pI,_),hdl),spec=(dI',pI',mI'),...} = + get_obj I pt p + val pblID = if pI' = e_pblID + then (*TODO.WN051125 (#init o get_pbt) pI <<<*) + takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*) + else pI' + val {ppc,where_,prls,...} = get_pbt pblID + val (model_ok, (pbl, pre)) = + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os + in (model_ok, pblID, hdl, pbl, pre) end; + +fun initcontext_met pt (pos as (p,_):pos') = + let val PblObj {meth,origin=(os,(_,_,mI), _),spec=(_, _, mI'),...} = + get_obj I pt p + val metID = if mI' = e_metID + then (*TODO.WN051125 (#init o get_pbt) pI <<<*) + takelast (2, mI) (*FIXME.WN051125 a hack, impl.^^^*) + else mI' + val {ppc,pre,prls,scr,...} = get_met metID + val (model_ok, (pbl, pre)) = + match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os + in (model_ok, metID, scr, pbl, pre) end; + +(*.match the model of a problem at pos p + with the model-pattern of the problem with pblID*) +fun context_pbl pI pt (p:pos) = + let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p + val {ppc,where_,prls,...} = get_pbt pI + val (model_ok, (pbl, pre)) = + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os + in (model_ok, pI, hdl, pbl, pre) end; + +fun context_met mI pt (p:pos) = + let val PblObj {meth,origin=(os,_,hdl),...} = get_obj I pt p + val {ppc,pre,prls,scr,...} = get_met mI + val (model_ok, (pbl, pre)) = + match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os + in (model_ok, mI, scr, pbl, pre) end + + +(* val (pI, pt, pos as (p,_)) = (pblID, pt, p); + *) +fun tryrefine pI pt (pos as (p,_):pos') = + let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p + in case refine_pbl (assoc_thy "Isac.thy") pI probl of + NONE => (*copy from context_pbl*) + let val {ppc,where_,prls,...} = get_pbt pI + val (_, (pbl, pre)) = match_itms_oris (assoc_thy "Isac.thy") + probl (ppc,where_,prls) os + in (false, pI, hdl, pbl, pre) end + | SOME (pI, (pbl, pre)) => + (true, pI, hdl, pbl, pre) + end; + +(* val (pt, (pos as (p,p_):pos')) = (pt, ip); + *) +fun detailstep pt (pos as (p,p_):pos') = + let val nd = get_nd pt p + val cn = children nd + in if null cn + then if (is_rewset o (get_obj g_tac nd)) [(*root of nd*)] + then detailrls pt pos + else ("no-Rewrite_Set...", EmptyPtree, e_pos') + else ("donesteps", pt(*, get_formress [] ((lev_on o lev_dn) p) cn*), + (p @ [length (children (get_nd pt p))], Res) ) + end; + + + +(***. for mathematics authoring on sml-toplevel; no XML .***) + +type NEW = int list; +(* val sp = (dI',pI',mI'); + *) + +(*15.8.03 for me with loc_specify/solve, nxt_specify/solve + delete as soon as TESTg_form -> _mout_ dropped*) +fun TESTg_form ptp = +(* val ptp = (pt,p); + *) + let val (form,_,_) = pt_extract ptp + in case form of + Form t => Form' (FormKF (~1,EdUndef,0,Nundef,term2str t)) + | ModSpec (_,p_, head, gfr, pre, _) => + Form' (PpcKF (0,EdUndef,0,Nundef, + (case p_ of Pbl => Problem[] | Met => Method[], + itms2itemppc (assoc_thy"Isac.thy") gfr pre))) + end; + +(*.create a calc-tree; for use within sml: thus ^^^ NOT decoded to ^; + compare "fun CalcTree" which DOES decode.*) +fun CalcTreeTEST [(fmz, sp):fmz] = +(* val [(fmz, sp):fmz] = [(fmz, (dI',pI',mI'))]; + val [(fmz, sp):fmz] = [([], ("e_domID", ["e_pblID"], ["e_metID"]))]; + *) + let val cs as ((pt,p), tacis) = nxt_specify_init_calc (fmz, sp) + val tac = case tacis of [] => Empty_Tac | _ => (#1 o hd) tacis + val f = TESTg_form (pt,p) + in (p, []:NEW, f, (tac2IDstr tac, tac), Sundef, pt) end; + +(*for tests > 15.8.03 after separation setnexttactic / nextTac: + external view: me should be used by math-authors as done so far + internal view: loc_specify/solve, nxt_specify/solve used + i.e. same as in setnexttactic / nextTac*) +(*ENDE TESTPHASE 08/10.03: + NEW loeschen, eigene Version von locatetac, step + meNEW, CalcTreeTEST: tac'_ -replace-> tac, remove [](cid) *) + +(* val ((_,tac), p, _, pt) = (nxt, p, c, pt); + *) +fun me ((_,tac):tac'_) (p:pos') (_:NEW(*remove*)) (pt:ptree) = + let val (pt, p) = +(* val (msg, (tacis, pos's, (pt',p'))) = locatetac tac (pt,p); + p = ([1, 9], Res); + (writeln o istate2str) (get_istate pt p); + *) + (*locatetac is here for testing by me; step would suffice in me*) + case locatetac tac (pt,p) of + ("ok", (_, _, ptp)) => ptp + | ("unsafe-ok", (_, _, ptp)) => ptp + | ("not-applicable",_) => (pt, p) + | ("end-of-calculation", (_, _, ptp)) => ptp + | ("failure",_) => raise error "sys-error"; + val (_, ts) = +(* val (eee, (ts, _, (pt'',_))) = step p ((pt, e_pos'),[]); + *) + (case step p ((pt, e_pos'),[]) of + ("ok", (ts as (tac,_,_)::_, _, _)) => ("",ts) + | ("helpless",_) => ("helpless: cannot propose tac", []) + | ("no-fmz-spec",_) => raise error "no-fmz-spec" + | ("end-of-calculation", (ts, _, _)) => ("",ts)) + handle _ => raise error "sys-error"; + val tac = case ts of tacis as (_::_) => +(* val tacis as (_::_) = ts; + *) + let val (tac,_,_) = last_elem tacis + in tac end + | _ => if p = ([],Res) then End_Proof' + else Empty_Tac; + (*form output comes from locatetac*) + in(p:pos',[]:NEW, TESTg_form (pt, p), + (tac2IDstr tac, tac):tac'_, Sundef, pt) end; + +(*for quick test-print-out, until 'type inout' is removed*) +fun f2str (Form' (FormKF (_, _, _, _, cterm'))) = cterm'; + + + +(*------------------------------------------------------------------(**) +end +open MathEngine; +(**)------------------------------------------------------------------*) + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/mstools.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/mstools.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,969 @@ +(* Types and tools for 'modeling' und 'specifying' to be used in + modspec.sml. The types are separated from calchead.sml into this file, + because some of them are stored in the calc-tree, and thus are required + _before_ ctree.sml. + author: Walther Neuper + (c) due to copyright terms + +use"ME/mstools.sml" (*re-evaluate sml/ from scratch!*); +use"mstools.sml"; +12345678901234567890123456789012345678901234567890123456789012345678901234567890 + 10 20 30 40 50 60 70 80 +*) + +signature SPECIFY_TOOLS = + sig + type envv + datatype + item = + Correct of cterm' + | False of cterm' + | Incompl of cterm' + | Missing of cterm' + | Superfl of string + | SyntaxE of string + | TypeE of string + val item2str : item -> string + type itm + val itm2str_ : Proof.context -> itm -> string + datatype + itm_ = + Cor of (term * term list) * (term * term list) + | Inc of (term * term list) * (term * term list) + | Mis of term * term + | Par of cterm' + | Sup of term * term list + | Syn of cterm' + | Typ of cterm' + val itm_2str : itm_ -> string + val itm_2str_ : Proof.context -> itm_ -> string + val itms2str_ : Proof.context -> itm list -> string + type 'a ppc + val ppc2str : + {Find: string list, With: string list, Given: string list, + Where: string list, Relate: string list} -> string + datatype + match = + Matches of pblID * item ppc + | NoMatch of pblID * item ppc + val match2str : match -> string + datatype + match_ = + Match_ of pblID * (itm list * (bool * term) list) + | NoMatch_ + val matchs2str : match list -> string + type ori + val ori2str : ori -> string + val oris2str : ori list -> string + type preori + val preori2str : preori -> string + val preoris2str : preori list -> string + type penv + (* val penv2str_ : Proof.context -> penv -> string *) + type vats + (*----------------------------------------------------------------------*) + val all_ts_in : itm_ list -> term list + val check_preconds : + 'a -> + rls -> + term list -> itm list -> (bool * term) list + val check_preconds' : + rls -> + term list -> + itm list -> 'a -> (bool * term) list + (* val chkpre2item : rls -> term -> bool * item *) + val pres2str : (bool * term) list -> string + (* val evalprecond : rls -> term -> bool * term *) + (* val cnt : itm list -> int -> int * int *) + val comp_dts : theory -> term * term list -> term + val comp_dts' : term * term list -> term + val comp_dts'' : term * term list -> string + val comp_ts : term * term list -> term + val d_in : itm_ -> term + val de_item : item -> cterm' + val dest_list : term * term list -> term list (* for testing *) + val dest_list' : term -> term list + val dts2str : term * term list -> string + val e_itm : itm + (* val e_listBool : term *) + (* val e_listReal : term *) + val e_ori : ori + val e_ori_ : ori + val empty_ppc : item ppc + (* val empty_ppc_ct' : cterm' ppc *) + (* val getval : term * term list -> term * term *) + (*val head_precond : + domID * pblID * 'a -> + term option -> + rls -> + term list -> + itm list -> 'b -> term * (bool * term) list*) + (* val init_item : string -> item *) + (* val is_matches : match -> bool *) + (* val is_matches_ : match_ -> bool *) + val is_var : term -> bool + (* val item_ppc : + string ppc -> item ppc *) + val itemppc2str : item ppc -> string + (* val matches_pblID : match -> pblID *) + val max2 : ('a * int) list -> 'a * int + val max_vt : itm list -> int + val mk_e : itm_ -> (term * term) list + val mk_en : int -> itm -> (term * term) list + val mk_env : itm list -> (term * term) list + val mkval : 'a -> term list -> term + val mkval' : term list -> term + (* val pblID_of_match : match -> pblID *) + val pbl_ids : Proof.context -> term -> term -> term list + val pbl_ids' : 'a -> term -> term list -> term list + (* val pen2str : theory -> term * term list -> string *) + val penvval_in : itm_ -> term list + val refined : match list -> pblID + val refined_ : + match_ list -> match_ option + (* val refined_IDitms : + match list -> match option *) + val split_dts : 'a -> term -> term * term list + val split_dts' : term * term -> term list + (* val take_apart : term -> term list *) + (* val take_apart_inv : term list -> term *) + val ts_in : itm_ -> term list + (* val unique : term *) + val untouched : itm list -> bool + val upd : + Proof.context -> + (''a * (''b * term list) list) list -> + term -> + ''b * term -> ''a -> ''a * (''b * term list) list + val upd_envv : + Proof.context -> + envv -> + vats -> + term -> term -> term -> envv + val upd_penv : + Proof.context -> + (''a * term list) list -> + term -> ''a * term -> (''a * term list) list + (* val upds_envv : + Proof.context -> + envv -> + (vats * term * term * term) list -> + envv *) + val vts_cnt : int list -> itm list -> (int * int) list + val vts_in : itm list -> int list + (* val w_itms2str_ : Proof.context -> itm list -> unit *) + end + +(*----------------------------------------------------------*) +structure SpecifyTools : SPECIFY_TOOLS = +struct +(*----------------------------------------------------------*) +val e_listReal = (term_of o the o (parse (theory "Script"))) "[]::(real list)"; +val e_listBool = (term_of o the o (parse (theory "Script"))) "[]::(bool list)"; + +(*.take list-term apart w.r.t. handling elementwise input.*) +fun take_apart t = + let val elems = isalist2list t + in map ((list2isalist (type_of (hd elems))) o single) elems end; +(*val t = str2term "[a, b]"; +> val ts = take_apart t; writeln (terms2str ts); +["[a]","[b]"] + +> t = (take_apart_inv o take_apart) t; +true*) +fun take_apart_inv ts = + let val elems = (flat o (map isalist2list)) ts; + in list2isalist (type_of (hd elems)) elems end; +(*val ts = [str2term "[a]", str2term "[b]"]; +> val t = take_apart_inv ts; term2str t; +"[a, b]" + +ts = (take_apart o take_apart_inv) ts; +true*) + + + + +(*.revert split_dts only for ts; compare comp_dts.*) +fun comp_ts (d, ts) = + if is_list_dsc d + then if is_list (hd ts) + then if is_unl d + then (hd ts) (*e.g. someList [1,3,2]*) + else (take_apart_inv ts) + (* SML[ [a], [b] ]SML --> [a,b] *) + else (hd ts) (*a variable or metavariable for a list*) + else (hd ts); +(*.revert split_. + WN050903 we do NOT know which is from subtheory, description or term; + typecheck thus may lead to TYPE-error 'unknown constant'; + solution: typecheck with Isac.thy; i.e. arg 'thy' superfluous*) +(*fun comp_dts thy (d,[]) = + cterm_of (*(sign_of o assoc_thy) "Isac.thy"*) + (theory "Isac") + (*comp_dts:FIXXME stay with term for efficiency !!!*) + (if is_reall_dsc d then (d $ e_listReal) + else if is_booll_dsc d then (d $ e_listBool) + else d) + | comp_dts thy (d,ts) = + (cterm_of (*(sign_of o assoc_thy) "Isac.thy"*) + (theory "Isac") + (*comp_dts:FIXXME stay with term for efficiency !!*) + (d $ (comp_ts (d, ts))) + handle _ => raise error ("comp_dts: "^(term2str d)^ + " $ "^(term2str (hd ts))));*) +fun comp_dts thy (d,[]) = + (if is_reall_dsc d then (d $ e_listReal) + else if is_booll_dsc d then (d $ e_listBool) + else d) + | comp_dts thy (d,ts) = + (d $ (comp_ts (d, ts))) + handle _ => raise error ("comp_dts: "^(term2str d)^ + " $ "^(term2str (hd ts))); +(*25.8.03*) +fun comp_dts' (d,[]) = + if is_reall_dsc d then (d $ e_listReal) + else if is_booll_dsc d then (d $ e_listBool) + else d + | comp_dts' (d,ts) = (d $ (comp_ts (d, ts))) + handle _ => raise error ("comp_dts': "^(term2str d)^ + " $ "^(term2str (hd ts))); +(*val t = str2term "maximum A"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +val it = "maximum A" : cterm +> val t = str2term "fixedValues [r=Arbfix]"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"fixedValues [r = Arbfix]" +> val t = str2term "valuesFor [a]"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"valuesFor [a]" +> val t = str2term "valuesFor [a,b]"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"valuesFor [a, b]" +> val t = str2term "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +relations [A = a * b, (a / 2) ^^^ 2 + (b / 2) ^^^ 2 = r ^^^ 2]" +> val t = str2term "boundVariable a"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"boundVariable a" +> val t = str2term "interval {x::real. 0 <= x & x <= 2*r}"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"interval {x. 0 <= x & x <= 2 * r}" + +> val t = str2term "equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"equality (sqrt (9 + 4 * x) = sqrt x + sqrt (5 + x))" +> val t = str2term "solveFor x"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"solveFor x" +> val t = str2term "errorBound (eps=0)"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"errorBound (eps = 0)" +> val t = str2term "solutions L"; +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); +"solutions L" + +before 6.5.03: +> val t = (term_of o the o (parse thy)) "testdscforlist [#1]"; +> val (d,ts) = split_dts t; +> comp_dts thy (d,ts); +val it = "testdscforlist [#1]" : cterm + +> val t = (term_of o the o (parse thy)) "(A::real)"; +> val (d,ts) = split_dts t; +val d = Const ("empty","empty") : term +val ts = [Free ("A","RealDef.real")] : term list +> val t = (term_of o the o (parse thy)) "[R=(R::real)]"; +> val (d,ts) = split_dts t; +val d = Const ("empty","empty") : term +val ts = [Const # $ Free # $ Free (#,#)] : term list +> val t = (term_of o the o (parse thy)) "[#1,#2]"; +> val (d,ts) = split_dts t; +val ts = [Free ("#1","'a"),Free ("#2","'a")] : NOT WANTED +*) + +(*for input_icalhd 11.03*) +fun comp_dts'' (d,[]) = + if is_reall_dsc d then term2str (d $ e_listReal) + else if is_booll_dsc d then term2str (d $ e_listBool) + else term2str d + | comp_dts'' (d,ts) = term2str (d $ (comp_ts (d, ts))) + handle _ => raise error ("comp_dts'': "^(term2str d)^ + " $ "^(term2str (hd ts))); + + + + + + +(* this may decompose an object-language isa-list; + use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*) +fun dest_list' t = if is_list t then isalist2list t else [t]; + +(*fun is_metavar (Free (str, _)) = + if (last_elem o explode) str = "_" then true else false + | is_metavar _ = false;*) +fun is_var (Free _) = true + | is_var _ = false; + +(*.special handling for lists. ?WN:14.5.03 ??!?*) +fun dest_list (d,ts) = + let fun dest t = + if is_list_dsc d andalso not (is_unl d) + andalso not (is_var t) (*..for pbt*) + then isalist2list t else [t] + in (flat o (map dest)) ts end; + + +(*.decompose an input into description, terms (ev. elems of lists), + and the value for the problem-environment; inv to comp_dts .*) +(*WN.8.6.03: corrected with minimal effort, +fn : theory -> term -> + term * description + term list * lists decomposed for elementwise input + term list pbl_ids not _HERE_: dont know which list-elems input*) +fun split_dts thy (t as d $ arg) = + if is_dsc d + then if is_list_dsc d + then if is_list arg + then if is_unl d + then (d, [arg]) (*e.g. someList [1,3,2]*) + else (d, take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*) + else (d, [arg]) (*a variable or metavariable for a list*) + else (d, [arg]) + else (e_term, dest_list' t(*9.01 ???*)) + | split_dts thy t = (*either dsc or term*) + let val (h,argl) = strip_comb t + in if (not o is_dsc) h then (e_term, dest_list' t) + else (h, dest_list (h,argl)) + end; +(* tests see fun comp_dts + +> val t = str2term "someList []"; +> val (_,ts) = split_dts thy t; writeln (terms2str ts); +["[]"] +> val t = str2term "valuesFor []"; +> val (_,ts) = split_dts thy t; writeln (terms2str ts); +["[]"]*) + +(*.version returning ts only.*) +fun split_dts' (d, arg) = + if is_dsc d + then if is_list_dsc d + then if is_list arg + then if is_unl d + then ([arg]) (*e.g. someList [1,3,2]*) + else (take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*) + else ([arg]) (*a variable or metavariable for a list*) + else ([arg]) + else (dest_list' arg(*9.01 ???*)) + | split_dts' (d, t) = (*either dsc or term; 14.5.03 only copied*) + let val (h,argl) = strip_comb t + in if (not o is_dsc) h then (dest_list' t) + else (dest_list (h,argl)) + end; + + + + + +(*27.8.01: problem-environment +WN.6.5.03: FIXXME reconsider if penv is worth the effort -- + -- just rerun a whole expl with num/var may show the same ?! +WN.9.5.03: penv-concept stalled, immediately generate script env ! + but [#0, epsilon] only outcommented for eventual reconsideration +*) +type penv = (term (*err_*) + * (term list) (*[#0, epsilon] 9.5.03 outcommented*) + ) list; +fun pen2str ctxt (t, ts) = + pair2str(Syntax.string_of_term ctxt t, + (strs2str' o map (Syntax.string_of_term ctxt)) ts); +fun penv2str_ thy (penv:penv) = (strs2str' o (map (pen2str thy))) penv; + +(* + 9.5.03: still unused, but left for eventual future development*) +type envv = (int * penv) list; (*over variants*) + +(*. 14.9.01: not used after putting penv-values into itm_ + make the result of split_* a value of problem-environment .*) +fun mkval dsc [] = raise error "mkval called with []" + | mkval dsc [t] = t + | mkval dsc ts = list2isalist ((type_of o hd) ts) ts; +(*WN.12.12.03*) +fun mkval' x = mkval e_term x; + + + +(*. get the constant value from a penv .*) +fun getval (id, values) = + case values of + [] => raise error ("penv_value: no values in '"^ + (Syntax.string_of_term (thy2ctxt' "Tools") id)) + | [v] => (id, v) + | (v1::v2::_) => (case v1 of + Const ("Script.Arbfix",_) => (id, v2) + | _ => (id, v1)); +(* + val e_ = (term_of o the o (parse thy)) "e_::bool"; + val ev = (term_of o the o (parse thy)) "#4 + #3 * x^^^#2 = #0"; + val v_ = (term_of o the o (parse thy)) "v_"; + val vv = (term_of o the o (parse thy)) "x"; + val r_ = (term_of o the o (parse thy)) "err_::bool"; + val rv1 = (term_of o the o (parse thy)) "#0"; + val rv2 = (term_of o the o (parse thy)) "eps"; + + val penv = [(e_,[ev]),(v_,[vv]),(r_,[rv2,rv2])]:penv; + map getval penv; +[(Free ("e_","bool"), + Const (#,#) $ (# $ # $ (# $ #)) $ Free ("#0","RealDef.real")), + (Free ("v_","RealDef.real"),Free ("x","RealDef.real")), + (Free ("err_","bool"),Free ("#0","RealDef.real"))] : (term * term) list +*) + + +(*23.3.02 TODO: ideas on redesign of type itm_,type item,type ori,type item ppc +(1) kinds of itms: + (1.1) untouched: for modeling only dsc displayed(impossible after match_itms) + =(presently) Mis (? should be Inc initially, and Mis after match_itms?) + (1.2) Syn,Typ,Sup: not related to oris + Syn, Typ (presently) should be accepted in appl_add (instead Error') + Sup (presently) should be accepted in appl_add (instead Error') + _could_ be w.r.t current vat (and then _is_ related to vat + Mis should _not_ be made Inc ((presently, by appl_add & match_itms) +- dsc in itm_ is timeconsuming -- keep id for respective queries ? +- order of items in ppc should be stable w.r.t order of itms + +- stepwise input of itms --- match_itms (in one go) ..not coordinated + - unify code + - match_itms / match_itms_oris ..2 versions ?! + (fast, for refine / slow, for modeling) + +- clarify: efficiency <--> simplicity !!! + ?: shift dsc itm_ -> itm | discard int in ori,itm | take int instead dsc + | take int for perserving order of item ppc in itms + | make all(!?) handling of itms stable against reordering(?) + | field in ori ?? (not from fmz!) -- meant for efficiency (not doc!???) + -"- "#undef" ?= not touched ?= (id,..) +----------------------------------------------------------------- +27.3.02: +def: type pbt = (field, (dsc, pid)) + +(1) fmz + pbt -> oris +(2) input + oris -> itm +(3) match_itms : schnell(?) f"ur refine + match_itms_oris : r"uckmeldung f"ur item ppc + +(1.1) in oris fehlt daher pid: (i,v,f,d,ts,pid) +---------- ^^^^^ --- dh. pbt meist als argument zu viel !!! + +(3.1) abwarten, wie das matchen mehr unterschiedlicher pbt's sich macht; + wenn Problem pbt v"ollig neue, dann w"are eigentlich n"otig ????: + (a) (_,_,d1,ts,_):ori + pbt -> (i,vt,d2,ts,pid) dh.vt neu ???? + (b) +*) + + + + +(*the internal representation of a models' item + + 4.9.01: not consistent: + after Init_Proof 'Inc', but after copy_probl 'Mis' - for same situation + (involves 'is_error'); + bool in itm really necessary ???*) +datatype itm_ = + Cor of (term * (* description *) + (term list)) * (* for list: elem-wise input *) + (*split_dts <-> comp_dts*) + (term * (term list)) (* elem of penv *) + (*9.5.03: ---- is already for script -- penv delayed to future*) + | Syn of cterm' + | Typ of cterm' + | Inc of (term * (term list)) * (term * (term list)) (*lists, + + init_pbl WN.11.03 FIXXME: empty penv .. bad + init_pbl should return Mis !!!*) + | Sup of (term * (term list)) (* user-input not found in pbt(+?oris?11.03)*) + | Mis of (term * term) (* after re-specification pbt-item not found + in pbl: only dsc, pid_*) + | Par of cterm'; (*internal state from fun parsitm*) + +type vats = int list; (*variants in formalizations*) + +(*.data-type for working on pbl/met-ppc: + in pbl initially holds descriptions (only) for user guidance.*) +type itm = + int * (* id =0 .. untouched - descript (only) from init + 23.3.02: seems to correspond to ori (fun insert_ppc) + <> maintain order in item ppc?*) + vats * (* variants - copy from ori *) + bool * (* input on this item is not/complete *) + string * (* #Given | #Find | #Relate *) + itm_; (* *) +(* use"ME/sequent.sml"; + *) +val e_itm = (0,[],false,"e_itm",Syn"e_itm"):itm; +(*in CalcTree/Subproblem an 'untouched' model is created + FIXME.WN.9.03 model should be filled to 'untouched' by Model/Refine_Problem*) +fun untouched (itms: itm list) = + foldl and_ (true ,map ((curry op= 0) o #1) itms); +(*> untouched []; +val it = true : bool +> untouched [e_itm]; +val it = true : bool +> untouched [e_itm, (1,[],false,"e_itm",Syn "e_itm")]; +val it = false : bool*) + + + + + +(* find most frequent variant v in itms *) + +fun vts_in itms = (distinct o flat o (map #2)) (itms:itm list); + +fun cnt itms v = (v,(length o (filter (curry op= v)) o + flat o (map #2)) (itms:itm list)); +fun vts_cnt vts itms = map (cnt itms) vts; +fun max2 [] = raise error "max2 of []" + | max2 (y::ys) = + let fun mx (a,x) [] = (a,x) + | mx (a,x) ((b,y)::ys) = + if x < y then mx (b,y) ys else mx (a,x) ys; +in mx y ys end; + +(*. find the variant with most items already input .*) +fun max_vt itms = + let val vts = (vts_cnt (vts_in itms)) itms; + in if vts = [] then 0 else (fst o max2) vts end; + + +(* TODO ev. make more efficient by avoiding flat *) +fun mk_e (Cor (_, iv)) = [getval iv] + | mk_e (Syn _) = [] + | mk_e (Typ _) = [] + | mk_e (Inc (_, iv)) = [getval iv] + | mk_e (Sup _) = [] + | mk_e (Mis _) = []; +fun mk_en vt ((i,vts,b,f,itm_):itm) = + if member op = vts vt then mk_e itm_ else []; +(*. extract the environment from an item list; + takes the variant with most items .*) +fun mk_env itms = + let val vt = max_vt itms + in (flat o (map (mk_en vt))) itms end; + + + +(*. example as provided by an author, complete w.r.t. pbt specified + not touched by any user action .*) +type ori = (int * (* id: 10.3.00ff impl. only <>0 .. touched + 21.3.02: insert_ppc needs it ! ?:purpose maintain + order in item ppc ???*) + vats * (* variants 21.3.02: related to pbt..discard ?*) + string * (* #Given | #Find | #Relate 21.3.02: discard ?*) + term * (* description *) + term list (* isalist2list t | [t] *) + ); +val e_ori_ = (0,[],"",e_term,[e_term]):ori; +val e_ori = (0,[],"",e_term,[e_term]):ori; + +fun ori2str ((i,vs,fi,t,ts):ori) = + "("^(string_of_int i)^", "^((strs2str o (map string_of_int)) vs)^", "^fi^","^ + (term2str t)^", "^((strs2str o (map term2str)) ts)^")"; +val oris2str = + let val s = !show_types + val _ = show_types:= true + val str = (strs2str' o (map (linefeed o ori2str))) + val _ = show_types:= s + in str end; + +(*.an or without leading integer.*) +type preori = (vats * + string * + term * + term list); +fun preori2str ((vs,fi,t,ts):preori) = + "("^((strs2str o (map string_of_int)) vs)^", "^fi^", "^ + (term2str t)^", "^((strs2str o (map term2str)) ts)^")"; +val preoris2str = (strs2str' o (map (linefeed o preori2str))); + +(*. given the input value (from split_dts) + make the value in a problem-env according to description-type .*) +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*) +fun pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) v = + if is_list v + then [v] (*eg. [r=Arbfix]*) + else (case v of (*eg. eps=#0*) + (Const ("op =",_) $ l $ r) => [r,l] + | _ => raise error ("pbl_ids Tools.nam: no equality " + ^(Syntax.string_of_term ctxt v))) + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.una",_)]))) v = [v] + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) v = [v] + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.str",_)]))) v = [v] + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) v = [v] + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))v = [v] + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))v = [v] + | pbl_ids ctxt _ v = raise error ("pbl_ids: not implemented for " + ^(Syntax.string_of_term ctxt v)); +(* +val t as t1 $ t2 = str2term "antiDerivativeName M_b"; +pbl_ids ctxt t1 t2; + + val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]"; + val (d,argl) = strip_comb t; + is_dsc d; (*see split_dts*) + dest_list (d,argl); + val (_ $ v) = t; + is_list v; + pbl_ids ctxt d v; +[Const ("List.list.Cons","[bool, bool List.list] => bool List.list") $ + (Const # $ Free # $ Const (#,#)) $ Const ("List.list.Nil","bool List.. + + val (dsc,vl) = (split_dts o term_of o the o (parse thy)) "solveFor x"; +val dsc = Const ("Descript.solveFor","RealDef.real => Tools.una") : term +val vl = Free ("x","RealDef.real") : term + + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_"; + pbl_ids ctxt dsc vl; +val it = [Free ("x","RealDef.real")] : term list + + val (dsc,vl) = (split_dts o term_of o the o(parse thy)) + "errorBound (eps=#0)"; + val (dsc,id) = (split_did o term_of o the o(parse thy)) "errorBound err_"; + pbl_ids ctxt dsc vl; +val it = [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")] : term list *) + +(*. given an already input itm, ((14.9.01: no difference to pbl_ids jet!!)) + make the value in a problem-env according to description-type .*) +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*) +fun pbl_ids' (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) vs = + (case vs of + [] => raise error ("pbl_ids' Tools.nam called with []") + | [t] => (case t of (*eg. eps=#0*) + (Const ("op =",_) $ l $ r) => [r,l] + | _ => raise error ("pbl_ids' Tools.nam: no equality " + ^(Syntax.string_of_term (thy2ctxt' "Isac")t))) + | vs' => vs (*14.9.01: ???TODO *)) + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.una",_)]))) vs = vs + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) vs = vs + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.str",_)]))) vs = vs + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) vs = vs + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))vs = vs + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))vs = vs + | pbl_ids' _ vs = + raise error ("pbl_ids': not implemented for " + ^(terms2str vs)); +(*9.5.03 penv postponed: pbl_ids'*) +fun pbl_ids' thy d vs = [comp_ts (d, vs)]; + + +(*14.9.01: not used after putting values for penv into itm_ + WN.5.5.03: used in upd .. upd_envv*) +fun upd_penv ctxt penv dsc (id, vl) = +(writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; + writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; + writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; + overwrite (penv, (id, pbl_ids ctxt dsc vl)) +); +(* + val penv = []; + val (dsc,vl) = (split_did o term_of o the o (parse thy)) "solveFor x"; + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_"; + val penv = upd_penv thy penv dsc (id, vl); +[(Free ("v_","RealDef.real"), + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")])] +: (term * term list) list + + val (dsc,vl) = (split_did o term_of o the o(parse thy))"errorBound (eps=#0)"; + val (dsc,id) = (split_did o term_of o the o(parse thy))"errorBound err_"; + upd_penv thy penv dsc (id, vl); +[(Free ("v_","RealDef.real"), + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")]), + (Free ("err_","bool"), + [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])] +: (term * term list) list ^.........!!!! +*) + +(*WN.9.5.03: not reconsidered; looks strange !!!*) +fun upd thy envv dsc (id, vl) i = + let val penv = case assoc (envv, i) of + SOME e => e + | NONE => []; + val penv' = upd_penv thy penv dsc (id, vl); + in (i, penv') end; +(* + val i = 2; + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv; + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b"; + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_"; + upd thy envv dsc (id, vl) i; +val it = (2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])]) + : int * (term * term list) list*) + + +(*14.9.01: not used after putting pre-penv into itm_*) +fun upd_envv thy (envv:envv) (vats:vats) dsc id vl = + let val vats = if length vats = 0 + then (*unknown id to _all_ variants*) + if length envv = 0 then [1] + else (intsto o length) envv + else vats + fun isin vats (i,_) = member op = vats i; + val envs_notin_vat = filter_out (isin vats) envv; + in ((map (upd thy envv dsc (id, vl)) vats) @ envs_notin_vat):envv end; +(* + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv; + + val vats = [2] + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b"; + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_"; + val envv = upd_envv thy envv vats dsc id vl; +val envv = [(2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])] + : (int * (term * term list) list) list + + val vats = [1,2,3]; + val (dsc,vl) = (split_did o term_of o the o(parse thy))"maximum A"; + val (dsc,id) = (split_did o term_of o the o(parse thy))"maximum m_"; + upd_envv thy envv vats dsc id vl; +[(1,[(Free ("m_","bool"),[Free ("A","bool")])]), + (2, + [(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")]), + (Free ("m_","bool"),[Free ("A","bool")])]), + (3,[(Free ("m_","bool"),[Free ("A","bool")])])] +: (int * (term * term list) list) list + + + val env = []:envv; + val (d,ts) = (split_dts o term_of o the o (parse thy)) + "fixedValues [r=Arbfix]"; + val (_,id) = (split_did o term_of o the o (parse thy))"fixedValues fix_"; + val vats = [1,2,3]; + val env = upd_envv thy env vats d id (mkval ts); +*) + +(*. update envv by folding from a list of arguments .*) +fun upds_envv thy envv [] = envv + | upds_envv thy envv ((vs, dsc, id, vl)::ps) = + upds_envv thy (upd_envv thy envv vs dsc id vl) ps; +(* eval test-maximum.sml until Specify_Method ... + val PblObj{probl=(_,pbl),origin=(_,(_,_,mI),_),...} = get_obj I pt []; + val met = (#ppc o get_met) mI; + + val envv = []; + val eargs = flat eargs; + val (vs, dsc, id, vl) = hd eargs; + val envv = upds_envv thy envv [(vs, dsc, id, vl)]; + + val (vs, dsc, id, vl) = hd (tl eargs); + val envv = upds_envv thy envv [(vs, dsc, id, vl)]; + + val (vs, dsc, id, vl) = hd (tl (tl eargs)); + val envv = upds_envv thy envv [(vs, dsc, id, vl)]; + + val (vs, dsc, id, vl) = hd (tl (tl (tl eargs))); + val envv = upds_envv thy envv [(vs, dsc, id, vl)]; +[(1, + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), + (Free ("m_","bool"),[Free (#,#)]), + (Free ("vs_","bool List.list"),[# $ # $ Const #]), + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]), + (2, + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), + (Free ("m_","bool"),[Free (#,#)]), + (Free ("vs_","bool List.list"),[# $ # $ Const #]), + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]), + (3, + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), + (Free ("m_","bool"),[Free (#,#)]), + (Free ("vs_","bool List.list"),[# $ # $ Const #])])] : envv *) + +(*for _output_ of the items of a Model*) +datatype item = + Correct of cterm' (*labels a correct formula (type cterm')*) + | SyntaxE of string (**) + | TypeE of string (**) + | False of cterm' (*WN050618 notexistent in itm_: only used in Where*) + | Incompl of cterm' (**) + | Superfl of string (**) + | Missing of cterm'; +fun item2str (Correct s) ="Correct " ^ s + | item2str (SyntaxE s) ="SyntaxE " ^ s + | item2str (TypeE s) ="TypeE " ^ s + | item2str (False s) ="False " ^ s + | item2str (Incompl s) ="Incompl " ^ s + | item2str (Superfl s) ="Superfl " ^ s + | item2str (Missing s) ="Missing " ^ s; +(*make string for error-msgs*) +fun itm_2str_ ctxt (Cor ((d,ts), penv)) = + "Cor " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ," + ^ pen2str ctxt penv + | itm_2str_ ctxt (Syn c) = "Syn " ^ c + | itm_2str_ ctxt (Typ c) = "Typ " ^ c + | itm_2str_ ctxt (Inc ((d,ts), penv)) = + "Inc " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ," + ^ pen2str ctxt penv + | itm_2str_ ctxt (Sup (d,ts)) = + "Sup " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) + | itm_2str_ ctxt (Mis (d,pid))= + "Mis "^ Syntax.string_of_term ctxt d ^ + " "^ Syntax.string_of_term ctxt pid + | itm_2str_ ctxt (Par s) = "Trm "^s; +fun itm_2str t = itm_2str_ (thy2ctxt' "Isac") t; +fun itm2str_ ctxt ((i,is,b,s,itm_):itm) = + "("^(string_of_int i)^" ,"^(ints2str' is)^" ,"^(bool2str b)^" ,"^ + s^" ,"^(itm_2str_ ctxt itm_)^")"; +fun itms2str_ ctxt itms = strs2str' (map (linefeed o (itm2str_ ctxt)) itms); +fun w_itms2str_ ctxt itms = writeln (itms2str_ ctxt itms); + +fun init_item str = SyntaxE str; + + + + +type 'a ppc = + {Given : 'a list, + Where: 'a list, + Find : 'a list, + With : 'a list, + Relate: 'a list}; +fun ppc2str {Given=Given,Where=Where,Find=Find,With=With,Relate=Relate}= + ("{Given =" ^ (strs2str Given ) ^ + ",Where=" ^ (strs2str Where) ^ + ",Find =" ^ (strs2str Find ) ^ + ",With =" ^ (strs2str With ) ^ + ",Relate=" ^ (strs2str Relate) ^ "}"); + + + + +fun item_ppc ({Given = gi,Where= wh, + Find = fi,With = wi,Relate= re}: string ppc) = + {Given = map init_item gi,Where= map init_item wh, + Find = map init_item fi,With = map init_item wi, + Relate= map init_item re}:item ppc; +fun itemppc2str ({Given=Given,Where=Where, + Find=Find,With=With,Relate=Relate}:item ppc)= + ("{Given =" ^ ((strs2str' o (map item2str)) Given ) ^ + ",Where=" ^ ((strs2str' o (map item2str)) Where) ^ + ",Find =" ^ ((strs2str' o (map item2str)) Find ) ^ + ",With =" ^ ((strs2str' o (map item2str)) With ) ^ + ",Relate=" ^ ((strs2str' o (map item2str)) Relate) ^ "}"); + +fun de_item (Correct x) = x + | de_item (SyntaxE x) = x + | de_item (TypeE x) = x + | de_item (False x) = x + | de_item (Incompl x) = x + | de_item (Superfl x) = x + | de_item (Missing x) = x; +val empty_ppc ={Given = [], + Where= [], + Find = [], + With = [], + Relate= []}:item ppc; +val empty_ppc_ct' ={Given = [], + Where = [], + Find = [], + With = [], + Relate= []}:cterm' ppc; + + +datatype match = + Matches of pblID * item ppc +| NoMatch of pblID * item ppc; +fun match2str (Matches (pI, ppc)) = + "Matches ("^(strs2str pI)^", "^(itemppc2str ppc)^")" + | match2str(NoMatch (pI, ppc)) = + "NoMatch ("^(strs2str pI)^", "^(itemppc2str ppc)^")"; +fun matchs2str ms = (strs2str o (map match2str)) ms; +fun pblID_of_match (Matches (pI,_)) = pI + | pblID_of_match (NoMatch (pI,_)) = pI; + +(*10.03 for Refine_Problem*) +datatype match_ = + Match_ of pblID * ((itm list) * ((bool * term) list)) +| NoMatch_; + +(*. the refined pbt is the last_element Matches in the list .*) +fun is_matches (Matches _) = true + | is_matches _ = false; +fun matches_pblID (Matches (pI,_)) = pI; +fun refined ms = ((matches_pblID o the o (find_first is_matches) o rev) ms) + handle _ => []:pblID; +fun refined_IDitms ms = ((find_first is_matches) o rev) ms; + +(*. the refined pbt is the last_element Matches in the list, + for Refine_Problem, tryrefine .*) +fun is_matches_ (Match_ _) = true + | is_matches_ _ = false; +fun refined_ ms = ((find_first is_matches_) o rev) ms; + + +fun ts_in (Cor ((_,ts),_)) = ts + | ts_in (Syn (c)) = [] + | ts_in (Typ (c)) = [] + | ts_in (Inc ((_,ts),_)) = ts + | ts_in (Sup (_,ts)) = ts + | ts_in (Mis _) = []; +(*WN050629 unused*) +fun all_ts_in itm_s = (flat o (map ts_in)) itm_s; +val unique = (term_of o the o (parse (theory "Real"))) "UnIqE_tErM"; +fun d_in (Cor ((d,_),_)) = d + | d_in (Syn (c)) = (writeln("*** d_in: Syn ("^c^")"); unique) + | d_in (Typ (c)) = (writeln("*** d_in: Typ ("^c^")"); unique) + | d_in (Inc ((d,_),_)) = d + | d_in (Sup (d,_)) = d + | d_in (Mis (d,_)) = d; + +fun dts2str (d,ts) = pair2str (term2str d, terms2str ts); +fun penvval_in (Cor ((d,_),(_,ts))) = [comp_ts (d,ts)] + | penvval_in (Syn (c)) = (writeln("*** penvval_in: Syn ("^c^")"); []) + | penvval_in (Typ (c)) = (writeln("*** penvval_in: Typ ("^c^")"); []) + | penvval_in (Inc (_,(_,ts))) = ts + | penvval_in (Sup dts) = (writeln("*** penvval_in: Sup "^(dts2str dts)); []) + | penvval_in (Mis (d,t)) = (writeln("*** penvval_in: Mis "^ + (pair2str(term2str d, term2str t))); []); + + +(*. check a predicate labelled with indication of incomplete substitution; +rls -> (*for eval_true*) +bool * (*have _all_ variables(Free) from the model-pattern + been substituted by a value from the pattern's environment ?*) +term (*the precondition*) +-> +bool * (*has the precondition evaluated to true*) +term (*the precondition (for map)*) +.*) +fun evalprecond prls (false, pre) = + (*NOT ALL Free's have been substituted, eg. because of incomplete model*) + (false, pre) + | evalprecond prls (true, pre) = +(* val (prls, pre) = (prls, hd pres'); + val (prls, pre) = (prls, hd (tl pres')); + *) + if eval_true (assoc_thy "Isac.thy") (*for Pattern.match *) + [pre] prls (*pre parsed, prls.thy*) + then (true , pre) + else (false , pre); + +fun pre2str (b, t) = pair2str(bool2str b, term2str t); +fun pres2str pres = strs2str' (map (linefeed o pre2str) pres); + +(*. check preconditions, return true if all true .*) +fun check_preconds' _ [] _ _ = [] (*empty preconditions are true*) + | check_preconds' prls pres pbl _(*FIXME.WN0308 mvat re-introduce*) = +(* val (prls, pres, pbl, _) = (prls, where_, probl, 0); + val (prls, pres, pbl, _) = (prls, pre, itms, mvat); + *) + let val env = mk_env pbl; + val pres' = map (subst_atomic_all env) pres; + in map (evalprecond prls) pres' end; + +fun check_preconds thy prls pres pbl = + check_preconds' prls pres pbl (max_vt pbl); + +(*----------------------------------------------------------*) +end +open SpecifyTools; +(*----------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/ptyps.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/ptyps.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1279 @@ +(* the problems and methods as stored in hierarchies + author Walther Neuper 1998 + (c) due to copyright terms + +use"ME/ptyps.sml"; +use"ptyps.sml"; +*) + +(*-----------------------------------------vvv-(1) aus modspec.sml 23.3.02*) +val dsc_unknown = (term_of o the o (parseold @{theory Script})) + "unknown::'a => unknow"; +(*-----------------------------------------^^^-(1) aus modspec.sml 23.3.02*) + + +(*-----------------------------------------vvv-(2) aus modspec.sml 23.3.02*) + +fun itm_2item thy (Cor ((d,ts),_)) = + Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) + | itm_2item _ (Syn c) = SyntaxE c + | itm_2item _ (Typ c) = TypeE c + | itm_2item thy (Inc ((d,ts),_)) = + Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) + | itm_2item thy (Sup (d,ts)) = + Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) + | itm_2item _ (Mis (d,pid)) = + Missing (Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^ + Syntax.string_of_term (thy2ctxt' "Isac") pid); + + +(* --- 8.3.00 +fun get_dsc_in dscppc sel = ((the (assoc (dscppc, sel))):term list) + handle _ => error ("get_dsc_in not for "^sel); + +fun dscs_in dscppc = + ((get_dsc_in dscppc "#Given") @ + (get_dsc_in dscppc "#Find") @ + (get_dsc_in dscppc "#Relate")):term list; + + --- 26.1.88 +fun get_dsc_of pblID sel = (the (assoc((snd o get_pbt) pblID, sel))); +fun get_dsc pblID = + (get_dsc_of pblID "#Given") @ + (get_dsc_of pblID "#Find") @ + (get_dsc_of pblID "#Relate"); + --- *) + +fun mappc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) = + {Given=map f gi, Where=map f wh, + Find=map f fi, With=map f wi, Relate=map f re}:'b ppc; +fun appc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) = + {Given=f gi, Where=f wh, + Find=f fi, With=f wi, Relate=f re}:'b ppc; + +(*for ppc of changing type*) +fun sel_ppc sel ppc = + case sel of + "#Given" => #Given (ppc:'a ppc) + | "#Where" => #Where (ppc:'a ppc) + | "#Find" => #Find (ppc:'a ppc) + | "#With" => #With (ppc:'a ppc) + | "#Relate" => #Relate (ppc:'a ppc) + | _ => raise error ("sel_ppc tried to select by '"^sel^"'"); + +fun repl_sel_ppc sel + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x = + case sel of + "#Given" => ({Given= x,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) + | "#Where" => {Given=gi,Where= x,Find=fi,With=wi,Relate=re} + | "#Find" => {Given=gi,Where=wh,Find= x,With=wi,Relate=re} + | "#With" => {Given=gi,Where=wh,Find=fi,With= x,Relate=re} + | "#Relate" => {Given=gi,Where=wh,Find=fi,With=wi,Relate= x} + | _ => raise error ("repl_sel_ppc tried to select by '"^sel^"'"); + +fun add_sel_ppc thy sel + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x = + case sel of + "#Given" => ({Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) + | "#Where" => {Given=gi,Where=wh@[x],Find=fi,With=wi,Relate=re} + | "#Find" => {Given=gi,Where=wh,Find=fi@[x],With=wi,Relate=re} + | "#Relate"=> {Given=gi,Where=wh,Find=fi,With=wi,Relate=re@[x]} + | "#undef" => {Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}(*ori2itmSup*) + | _ => raise error ("add_sel_ppc tried to select by '"^sel^"'"); +fun add_where ({Given=gi,Find=fi,With=wi,Relate=re,...}:'a ppc) wh = + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc); + +(*-----------------------------------------^^^-(2) aus modspec.sml 23.3.02*) + + +(*-----------------------------------------vvv-(3) aus modspec.sml 23.3.02*) + + + +(*decompose a problem-type into description and identifier + FIXME split_dsc: no term list !!! (just for quick redoing prep_ori) *) +fun split_dsc thy t = + (let val (hd,args) = strip_comb t + in if is_dsc hd + then (hd, args) + else (e_term, [t]) (*??? 9.01 just copied*) + end) + handle _ => raise error ("split_dsc: called with "^ + (Syntax.string_of_term (thy2ctxt' "Isac") t)); +(* +> val t1 = (term_of o the o (parse thy)) "errorBound err_"; +> split_dsc t1; +(Const ("Descript.errorBound","bool => Tools.nam"),Free ("err_","bool")) + : term * term +> val t3 = (term_of o the o (parse thy)) "valuesFor vs_"; +> split_dsc t3; +(Const ("Descript.valuesFor","bool List.list => Tools.toreall"), + Free ("vs_","bool List.list")) : term * term*) + + + +(*. take the first two return-values; for prep_ori .*) +(*WN.13.5.03fun split_dts' thy t = + let val (d, ts, _) = split_dts thy t + in (d, ts) end;*) +(*WN.8.12.03 quick for prep_ori'*) +fun split_dsc' t = + (let val dsc $ var = t + in var end) + handle _ => raise error ("split_dsc': called with "^term2str t); + +(*9.3.00*) +(* split a term into description and (id | structured variable) + for pbt, met.ppc *) +fun split_did t = + (let val (hd,[arg]) = strip_comb t + in (hd,arg) end) + handle _ => raise error ("split_did: doesn't match (hd,[arg]) for t = " + ^(Syntax.string_of_term (thy2ctxt' "Script") t)); + + + +(*create output-string for itm_*) +fun itm_out thy (Cor ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm_out thy (Syn c) = c + | itm_out thy (Typ c) = c + | itm_out thy (Inc ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm_out thy (Sup (d,ts)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm_out thy (Mis (d,pid)) = + Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^ + Syntax.string_of_term (thy2ctxt' "Isac") pid; + +(*22.11.00 unused +fun itm_ppc2str thy ipc = (ppc2str o (mappc (itm__2str thy))) ipc;*) + + +(*--3.3. +fun itms2dts itms = + let + fun coll itms' [] = itms' + | coll itms' (i::itms) = + case i of + (Cor (d,ts)) => coll (itms' @ [(d,ts)]) itms + | (Syn c) => coll (itms' ) itms + | (Typ c) => coll (itms' ) itms + | (Fal (d,ts)) => coll (itms' @ [(d,ts)]) itms + | (Inc (d,ts)) => coll (itms' @ [(d,ts)]) itms + | (Sup (d,ts)) => coll (itms' @ [(d,ts)]) itms + in coll [] itms end; +*) +(*--3.3.00 +fun itm2item ((_,_,_,_,Cor (d,ts)):itm) = + Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm2item (_,_,_,_,Syn (c)) = SyntaxE c + | itm2item (_,_,_,_,Typ (c)) = TypeE c + | itm2item (_,_,_,_,Fal (d,ts)) = + False (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm2item (_,_,_,_,Inc (d,ts)) = + Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) + | itm2item (_,_,_,_,Sup (d,ts)) = + Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))); +*) + +fun boolterm2item (true, term) = Correct (term2str term) + | boolterm2item (false, term) = False (term2str term); + +(* use"ME/modspec.sml"; + *) +fun itms2itemppc thy (itms:itm list) (pre:(bool * term) list) = + let + fun coll ppc [] = ppc + | coll ppc ((_,_,_,field,itm_)::itms) = + coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms; + val gfr = coll empty_ppc itms; + in add_where gfr (map boolterm2item pre) end; +(*-----------------------------------------^^^-(3) aus modspec.sml 23.3.02*) + +(*-----------------------------------------vvv-(4) aus modspec.sml 23.3.02*) + +(* --- 9.3.fun add_field dscs (d,ts) = + if d mem (get_dsc_in dscs "#Given") + then ("#Given",d,ts:term list) + else if d mem (get_dsc_in dscs "#Find") + then ("#Find",d,ts) + else if d mem (get_dsc_in dscs "#Relate") + then ("#Relate",d,ts) + else ("#undef",d,ts); +(* 28.1.00 raise error ("add_field: '"^ + (Syntax.string_of_term (thy2ctxt' "Isac") d)^ + "' not in ppc-description "); *) + ------9.3. *) + +(* 9.3.00 + compare d and dsc in pbt and transfer field to pre-ori *) +fun add_field thy pbt (d,ts) = + let fun eq d pt = (d = (fst o snd) pt); + in case filter (eq d) pbt of + [(fi,(dsc,_))] => (fi,d,ts) + | [] => ("#undef",d,ts) (*may come with met.ppc*) + | _ => raise error ("add_field: "^ + (Syntax.string_of_term (thy2ctxt' "Isac") d)^ + " more than once in pbt") + end; + +(*. take over field from met.ppc at 'Specify_Method' into ori, + i.e. also removes "#undef" fields .*) +(* val (mpc, ori) = ((#ppc o get_met) mID, oris); + *) +fun add_field' thy mpc (ori:ori list) = + let fun eq d pt = (d = (fst o snd) pt); + fun repl mpc (i,v,_,d,ts) = + case filter (eq d) mpc of + [(fi,(dsc,_))] => [(i,v,fi,d,ts)] + | [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*) + (*raise error ("add_field': "^ + (Syntax.string_of_term (thy2ctxt' "Isac") d)^ + " not in met"*) + | _ => raise error ("add_field': "^ + (Syntax.string_of_term (thy2ctxt' "Isac") d)^ + " more than once in met"); + in (flat ((map (repl mpc)) ori)):ori list end; + + +(*.mark an element with the position within a plateau; + a plateau with length 1 is marked with 0 .*) +fun mark eq [] = raise error "mark []" + | mark eq xs = + let + fun mar xx eq [x] n = xx @ [(if n=1 then 0 else n,x)] + | mar xx eq (x::x'::xs) n = + if eq(x,x') then mar (xx @ [(n,x)]) eq (x'::xs) (n+1) + else mar (xx @ [(if n=1 then 0 else n,x)]) eq (x'::xs) 1; + in mar [] eq xs 1 end; +(* +> val xs = [1,1,1,2,4,4,5]; +> mark (op=) xs; +val it = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)] +*) + +(*.assumes equal descriptions to be in adjacent 'plateaus', + items at a certain position within the plateaus form a variant; + length = 1 ... marked with 0: covers all variants .*) +fun add_variants fdts = + let + fun eq (a,b) = curry op= (snd3 a) (snd3 b); + in mark eq fdts end; + +(* collect equal elements: the model for coll_variants *) +fun coll eq xs = + let + fun col xs eq x [] = xs @ [x] + | col xs eq x (y::ys) = + if eq(x,y) then col xs eq x ys + else col (xs @ [x]) eq y ys; + in col [] eq (hd xs) xs end; +(* +> val xs = [1,1,1,2,4,4,4]; +> coll (op=) xs; +val it = [1,2,4] : int list +*) + +fun max [] = raise error "max of []" + | max (y::ys) = + let fun mx x [] = x + | mx x (y::ys) = if x < y then mx y ys else mx x ys; +in mx y ys end; +fun gen_max _ [] = raise error "gen_max of []" + | gen_max ord (y::ys) = + let fun mx x [] = x + | mx x (y::ys) = if ord (x, y) then mx y ys else mx x ys; +in mx y ys end; + + + +(* assumes *) +fun coll_variants (((v,x)::vxs)) = + let + fun col xs (vs,x) [] = xs @ [(vs,x)] + | col xs (vs,x) ((v',x')::vxs') = + if x=x' then col xs (vs @ [v'], x') vxs' + else col (xs @ [(vs,x)]) ([v'], x') vxs'; + in col [] ([v],x) vxs end; +(* val xs = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)]; +> col [] ([(fst o hd) xs],(snd o hd) xs) (tl xs); +val it = [([1,2,3],1),([0],2),([1,2],4),([0],5)] *) + + +fun replace_0 vm [0] = intsto vm + | replace_0 vm vs = vs; + +fun add_id [] = raise error "add_id []" + | add_id xs = + let fun add n [] = [] + | add n (x::xs) = (n,x) :: add (n+1) xs; +in add 1 xs end; +(* +> val xs = [([1,2,3],1),([0],2),([1,2],4),([0],5)]; +> add_id xs; +val it = [(1,([#,#,#],1)),(2,([#],2)),(3,([#,#],4)),(4,([#],5))] + *) + +fun flattup (a,(b,(c,d,e))) = (a,b,c,d,e); +fun flattup' (a,(b,((c,d),e))) = (a,b,c,d,e); +fun flat3 (a,(b,c)) = (a,b,c); +(* + val pI = pI'; + !pbts; +*) +(* in root (only!) fmz may be empty: fill with ..,dsc,[] +fun init_ori fmz thy pI = + if fmz <> [] then prep_ori fmz thy pI (*fmz assumed complete*) + else + let + val fds = map (cons2 (fst, fst o snd)) (get_pbt pI); + val vfds = map ((pair [1]) o (rpair [])) fds; + val ivfds = add_id vfds + in (map flattup' ivfds):ori list end; 10.3.00---*) +(* val fmz = ctl; val pI=["sqroot-test","univariate","equation"]; + val (thy,pbt) = (assoc_thy dI',(#ppc o get_pbt) pI'); + val (fmz, thy, pbt) = (fmz, thy, ((#ppc o get_pbt) pI)); + *) +fun prep_ori [] _ _ = [] + | prep_ori fmz thy pbt = + let + val ctopts = map (parse thy) fmz + val _= (*FIXME.WN060916 improve error report*) + if null (filter is_none ctopts) then () + else raise error ("prep_ori: SYNTAX ERROR in " ^ strs2str' fmz) + val dts = map ((split_dts thy) o term_of o the) ctopts + val ori = map (add_field thy pbt) dts; +(* val ori = map (flat3 o (pair "#undef")) dts; *) + val ori' = add_variants ori; + val maxv = max (map fst ori'); + val maxv = if maxv = 0 then 1(*only 1 variant*) else maxv; + val ori'' = coll_variants ori'; + val ori''' = map (apfst (replace_0 maxv)) ori''; + val ori'''' = add_id ori''' + in (map flattup ori''''):ori list end; + + +(*-----------------------------------------^^^-(4) aus modspec.sml 23.3.02*) + +(*.the pattern for an item of a problems model or a methods guard.*) +type pat = (string * (*field*) + (term * (*description*) + term)) (*id | struct-var*); +fun pat2str ((field, (dsc, id)):pat) = + pair2str (field, pair2str (term2str dsc, term2str id)); +fun pats2str pats = (strs2str o (map pat2str)) pats; + +(* data for methods stored in 'methods'-database *) +type met = + {guh : guh, (*unique within this isac-knowledge *) + mathauthors: string list,(*copyright *) + init : pblID, (*WN060721 introduced mistakenly--TODO.REMOVE!*) + rew_ord' : rew_ord', (*for rules in Detail + TODO.WN0509 store fun itself, see 'type pbt'*) + erls : rls, (*the eval_rls for cond. in rules FIXME "rls' + instead erls in "fun prep_met" *) + srls : rls, (*for evaluating list expressions in scr *) + prls : rls, (*for evaluating predicates in modelpattern *) + crls : rls, (*for check_elementwise, ie. formulae in calc.*) + nrls : rls, (*canonical simplifier specific for this met *) + calc : calc list, (*040207: <--- calclist' in fun prep_met *) + (*branch : TransitiveB set in append_problem at generation ob pblobj + FIXXXME.8.03: set branch from met in Apply_Method *) + + (* compare type pbt:*) + ppc: pat list, + (*.items in given, find, relate; + items (in "#Find") which need not occur in the arg-list of a SubProblem + are 'copy-named' with an identifier "*_!_". + copy-named items are 'generating' if they are NOT "*___" + see ME/calchead.sml 'fun is_copy_named'.*) + pre: term list, (*preconditions in where*) + (*script*) + scr: scr (*prep_met requires either script or string "empty_script"*) + }; +(* ------- template ------------------------------------------------------ +store_met + (prep_met *.thy + ([(*"EqSystem","normalize"*)], + [("#Given" ,[ (*"equalities es_", "solveForVars vs_"*)]), + ("#Find" ,[ (*dont forget typing non-reals *)]), + ("#Relate",[])(*may be omitted *) ], + {calc = [], (*filled autom. in prep_met *) + crls = Erls, (*for check_elementwise *) + prls = Erls, (*for evaluating preds in guard *) + nrls = Erls, (*can.simplifier for all formulae*) + rew_ord'="tless_true", (*for rules in Detail *) + rls' = Erls, (*erls, the eval_rls for cond. in rules*) + srls = Erls}, (*for evaluating list expr in scr*) + "empty_script" + )); +---------- template ----------------------------------------------------*) +val e_met = {guh="met_empty",mathauthors=[],init=e_metID, + rew_ord' = "e_rew_ord'": rew_ord', + erls = e_rls, srls = e_rls, prls = e_rls, + calc = [], crls = e_rls, nrls = e_rls, + (*asm_thm = []: thm' list, + asm_rls = []: rls' list,*) + ppc = []: (string * (term * term)) list, + pre = []: term list, + scr = EmptyScr: scr}:met; + + +(** problem-types stored in format for usage in specify **) +(*25.8.01 ---- +val pbltypes = ref ([(e_pblID,[])]:(pblID * ((string * (* field "#Given",..*) + (term * (* description *) + term)) (* id | struct-var *) + list) + ) list);*) + +(*deprecated due to 'type pat'*) +type pbt_ = (string * (* field "#Given",..*) + (term * (* description *) + term)); (* id | struct-var *) +val e_pbt_ = ("#Undef", (e_term, e_term)):pbt_; +type pbt = + {guh : guh, (*unique within this isac-knowledge*) + mathauthors: string list, (*copyright*) + init : pblID, (*to start refinement with*) + thy : theory, (* which allows to compile that pbt + TODO: search generalized for subthy (ref.p.69*) + (*^^^ WN050912 NOT used during application of the problem, + because applied terms may be from 'subthy' as well as from super; + thus we take 'maxthy'; see match_ags !*) + cas : term option,(*'CAS-command'*) + prls : rls, (* for preds in where_*) + where_: term list, (* where - predicates*) + ppc : pat list, + (*this is the model-pattern; + it contains "#Given","#Where","#Find","#Relate"-patterns*) + met : metID list}; (* methods solving the pbt*) +val e_pbt = {guh="pbl_empty",mathauthors=[],init=e_pblID,thy=theory "Pure", + cas=NONE,prls=Erls,where_=[],ppc=[],met=[]}:pbt; +fun pbt2 (str, (t1, t2)) = + pair2str (str, pair2str (term2str t1, term2str t2)); +fun pbt2str pbt = (strs2str o (map (linefeed o pbt2))) pbt; + + +val e_Ptyp = Ptyp ("e_pblID",[e_pbt],[]); +val e_Mets = Ptyp ("e_metID",[e_met],[]); + +type ptyps = (pbt ptyp) list; +val ptyps = ref ([e_Ptyp]:ptyps); + +type mets = (met ptyp) list; +val mets = ref ([e_Mets]:mets); + + +(**+ breadth-first search on hierarchy of problem-types +**) + +type pblRD = pblID;(*pblID are Reverted _on calling_ the retrieve-funs*) + (* eg. ["equations","univariate","normalize"] while + ["normalize","univariate","equations"] is the related pblID + WN.24.4.03: also used for metID*) + +fun get_py thy d _ [] = + error ("get_pbt not found: "^(strs2str d)) + | get_py thy d [k] ((Ptyp (k',[py],_))::pys) = + if k=k' then py + else get_py thy d ([k]:pblRD) pys + | get_py thy d (k::ks) ((Ptyp (k',_,pys))::pys') = + if k=k' then get_py thy d ks pys + else get_py thy d (k::ks) pys'; +(*> ptyps:= +[Ptyp ("1",[("ptyp 1",([],[]))], + [Ptyp ("11",[("ptyp 11",([],[]))], + []) + ]), + Ptyp ("2",[("ptyp 2",([],[]))], + [Ptyp ("21",[("ptyp 21",([],[]))], + []) + ]) + ]; +> get_py SqRoot.thy ["1"] ["1"] (!ptyps); +> get_py SqRoot.thy ["2","21"] ["2","21"] (!ptyps); + _REVERSE_ .......... !!!!!!!!!!*) + +(*TODO: search generalized for subthy*) +fun get_pbt (pblID:pblID) = + let val pblRD = rev pblID; + in get_py (theory "Pure") pblID pblRD (!ptyps) end; +(* get_pbt thy ["1"]; + get_pbt thy ["21","2"]; + *) + +(*TODO: throws exn 'get_pbt not found: ' ... confusing !! + take 'ketype' as an argument !!!!!*) +fun get_met (metID:metID) = get_py (theory "Pure") metID metID (!mets); +fun get_the (theID:theID) = get_py (theory "Pure") theID theID (!thehier); + + + +fun del_eq k ptyps = +let fun del k ptyps [] = ptyps + | del k ptyps ((Ptyp (k', [p], ps))::pys) = + if k=k' then del k ptyps pys + else del k (ptyps @ [Ptyp (k', [p], ps)]) pys; +in del k [] ptyps end; + +fun insrt d pbt [k] [] = [Ptyp (k, [pbt],[])] + + | insrt d pbt [k] ((Ptyp (k', [p], ps))::pys) = +((*writeln("### insert 1: ks = "^(strs2str [k])^" k'= "^k');*) + if k=k' + then ((Ptyp (k', [pbt], ps))::pys) + else (*ev.newly added pbt is free _only_ with 'last_elem pblID'*) + ((Ptyp (k', [p], ps))::(insrt d pbt [k] pys)) +) + | insrt d pbt (k::ks) ((Ptyp (k', [p], ps))::pys) = +((*writeln("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*) + if k=k' + then ((Ptyp (k', [p], insrt d pbt ks ps))::pys) + else + if length pys = 0 + then error ("insert: not found "^(strs2str (d:pblID))) + else ((Ptyp (k', [p], ps))::(insrt d pbt (k::ks) pys)) +); + + +fun coll_pblguhs pbls = + let fun node coll (Ptyp (_,[n],ns)) = + [(#guh : pbt -> guh) n] @ (nodes coll ns) + and nodes coll [] = coll + | nodes coll (n::ns) = (node coll n) @ (nodes coll ns); + in nodes [] pbls end; +fun coll_metguhs mets = + let fun node coll (Ptyp (_,[n],ns)) = + [(#guh : met -> guh) n] + and nodes coll [] = coll + | nodes coll (n::ns) = (node coll n) @ (nodes coll ns); + in nodes [] mets end; + +(*.lookup a guh in hierarchy or methods depending on fst chars in guh.*) +fun guh2kestoreID (guh:guh) = + case (implode o (take_fromto 1 4) o explode) guh of + "pbl_" => + let fun node ids gu (Ptyp (id,[n as {guh,...} : pbt], ns)) = + if gu = guh + then SOME ((ids@[id]) : kestoreID) + else nodes (ids@[id]) gu ns + and nodes _ _ [] = NONE + | nodes ids gu (n::ns) = + case node ids gu n of SOME id => SOME id + | NONE => nodes ids gu ns + in case nodes [] guh (!ptyps) of + SOME id => rev id + | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^ + "not found in (!ptyps)") + end + | "met_" => + let fun node ids gu (Ptyp (id,[n as {guh,...} : met], ns)) = + if gu = guh + then SOME ((ids@[id]) : kestoreID) + else nodes (ids@[id]) gu ns + and nodes _ _ [] = NONE + | nodes ids gu (n::ns) = + case node ids gu n of SOME id => SOME id + | NONE => nodes ids gu ns + in case nodes [] guh (!mets) of + SOME id => id + | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^ + "not found in (!mets)") end + | _ => error ("guh2kestoreID called with '" ^ guh ^ "'"); +(*> guh2kestoreID "pbl_equ_univ_lin"; +val it = ["linear", "univariate", "equation"] : string list*) + + +fun check_pblguh_unique (guh:guh) (pbls: (pbt ptyp) list) = + if member op = (coll_pblguhs pbls) guh + then error ("check_guh_unique failed with '"^guh^"';\n"^ + "use 'sort_pblguhs()' for a list of guhs;\n"^ + "consider setting 'check_guhs_unique := false'") + else (); +(* val (guh, mets) = ("met_test", !mets); + *) +fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) = + if member op = (coll_metguhs mets) guh + then error ("check_guh_unique failed with '"^guh^"';\n"^ + "use 'sort_metguhs()' for a list of guhs;\n"^ + "consider setting 'check_guhs_unique := false'") + else (); + + + +(*.the pblID has the leaf-element as first; better readability achieved;.*) +fun store_pbt (pbt as {guh,...}, pblID) = + (if (!check_guhs_unique) then check_pblguh_unique guh (!ptyps) else (); + ptyps:= insrt pblID pbt (rev pblID) (!ptyps)); + +(*.the metID has the root-element as first; compare 'fun store_pbt'.*) +(* val (met as {guh,...}, metID) = + ((prep_met EqSystem.thy "met_eqsys" [] e_metID + (["EqSystem"], + [], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, + "empty_script" + ))); + *) +fun store_met (met as {guh,...}, metID) = + (if (!check_guhs_unique) then check_metguh_unique guh (!mets) else (); + mets:= insrt metID met metID (!mets)); + + +(*. prepare problem-types before storing in pbltypes; + dont forget to 'check_guh_unique' before ins.*) +fun prep_pbt thy guh maa init + (pblID, dsc_dats: (string * (string list)) list, + ev:rls, ca: string option, metIDs:metID list) = +(* val (thy, (pblID, dsc_dats: (string * (string list)) list, + ev:rls, ca: string option, metIDs:metID list)) = + ((EqSystem.thy, (["system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Find" ,["solution ss___"](*___ is copy-named*)) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "solveSystem es_ vs_", + []))); + *) + let fun eq f (f', _) = f = f'; + val gi = filter (eq "#Given") dsc_dats; +(*val gi = [("#Given",["equality e_","solveFor v_"])] + : (string * string list) list*) + val gi = (case gi of + [] => [] + | ((_,gi')::[]) => + ((map (split_did o term_of o the o (parse thy)) gi') + handle _ => error + ("prep_pbt: syntax error in '#Given' of "^ + (strs2str pblID))) + | _ => + (error ("prep_pbt: more than one '#Given' in "^ + (strs2str pblID)))); +(*val gi = + [(Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool")), + (Const ("Descript.solveFor","RealDef.real => Tools.una"), + Free ("v_","RealDef.real"))] : (term * term) list *) + val gi = map (pair "#Given") gi; +(*val gi = + [("#Given", + (Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool"))), + ("#Given", + (Const ("Descript.solveFor","RealDef.real => Tools.una"), + Free ("v_","RealDef.real")))] : (string * (term * term)) list*) + + val fi = filter (eq "#Find") dsc_dats; + val fi = (case fi of + [] => [](*28.8.01: ["tool"] ...// raise error + ("prep_pbt: no '#Find' in "^(strs2str pblID))*) +(* val ((_,fi')::[]) = fi; + *) + | ((_,fi')::[]) => + ((map (split_did o term_of o the o (parse thy)) fi') + handle _ => raise error + ("prep_pbt: syntax error in '#Find' of "^ + (strs2str pblID))) + | _ => + (raise error ("prep_pbt: more than one '#Find' in "^ + (strs2str pblID)))); + val fi = map (pair "#Find") fi; + + val re = filter (eq "#Relate") dsc_dats; + val re = (case re of + [] => [] + | ((_,re')::[]) => + ((map (split_did o term_of o the o (parse thy)) re') + handle _ => raise error + ("prep_pbt: syntax error in '#Relate' of "^ + (strs2str pblID))) + | _ => + (raise error ("prep_pbt: more than one '#Relate' in "^ + (strs2str pblID)))); + val re = map (pair "#Relate") re; + + val wh = filter (eq "#Where") dsc_dats; + val wh = (case wh of + [] => [] + | ((_,wh')::[]) => + ((map (term_of o the o (parse thy)) wh') + handle _ => raise error + ("prep_pbt: syntax error in '#Where' of "^ + (strs2str pblID))) + | _ => + (raise error ("prep_pbt: more than one '#Where' in "^ + (strs2str pblID)))); + in ({guh=guh,mathauthors=maa,init=init, + thy=thy,cas= case ca of NONE => NONE + | SOME s => + SOME ((term_of o the o (parse thy)) s), + prls=ev,where_=wh,ppc= gi @ fi @ re, + met=metIDs}, pblID):pbt * pblID end; +(* prep_pbt thy (pblID, dsc_dats, metIDs); + val it = + ({met=[], + ppc=[("#Given",(Const (#,#),Free (#,#))), + ("#Given",(Const (#,#),Free (#,#))), + ("#Find",(Const (#,#),Free (#,#)))], + thy={ProtoPure, ..., Atools, RatArith}, + where_=[Const ("Descript.solutions","bool List.list => Tools.toreall") $ + Free ("v_i_","bool List.list")]},["equation"]) : pbt * pblID *) + + + + +(*. prepare met for storage analogous to pbt .*) +fun prep_met thy guh maa init + (metID, ppc: (string * string list) list (*'#Where' -> #pre*), + {rew_ord'=ro, rls'=rls, srls=srls, prls=prls, + calc = scr_isa_fns(*FIXME.040207: del - auto-done*), + crls=cr, nrls=nr}, scr) = + let fun eq f (f', _) = f = f'; + (*val thy = (assoc_thy o fst) metID*) + val gi = filter (eq "#Given") ppc; + val gi = (case gi of + [] => [] + | ((_,gi')::[]) => + ((map (split_did o term_of o the o (parse thy)) gi') + handle _ => raise error + ("prep_pbt: syntax error in '#Given' of "^ + (strs2str metID))) + | _ => + (raise error ("prep_pbt: more than one '#Given' in "^ + (strs2str metID)))); + val gi = map (pair "#Given") gi; + + val fi = filter (eq "#Find") ppc; + val fi = (case fi of + [] => [](*28.8.01: ["tool"] ...// raise error + ("prep_pbt: no '#Find' in "^(strs2str metID))*) + | ((_,fi')::[]) => + ((map (split_did o term_of o the o (parse thy)) fi') + handle _ => raise error + ("prep_pbt: syntax error in '#Find' of "^ + (strs2str metID))) + | _ => + (raise error ("prep_pbt: more than one '#Find' in "^ + (strs2str metID)))); + val fi = map (pair "#Find") fi; + + val re = filter (eq "#Relate") ppc; + val re = (case re of + [] => [] + | ((_,re')::[]) => + ((map (split_did o term_of o the o (parse thy)) re') + handle _ => raise error + ("prep_pbt: syntax error in '#Relate' of "^ + (strs2str metID))) + | _ => + (raise error ("prep_pbt: more than one '#Relate' in "^ + (strs2str metID)))); + val re = map (pair "#Relate") re; + + val wh = filter (eq "#Where") ppc; + val wh = (case wh of + [] => [] + | ((_,wh')::[]) => + ((map (term_of o the o (parse thy)) wh') + handle _ => raise error + ("prep_pbt: syntax error in '#Where' of "^ + (strs2str metID))) + | _ => + (raise error ("prep_pbt: more than one '#Where' in "^ + (strs2str metID)))); + val sc = (((inst_abs thy) o term_of o the o (parse thy)) scr) + in ({guh=guh,mathauthors=maa,init=init, + ppc=gi@fi@re, pre=wh, rew_ord'=ro, erls=rls, srls=srls, prls=prls, + calc = if scr = "empty_script" then [] + else ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o + (filter is_calc) o stacpbls) sc, + crls=cr, nrls=nr, scr=Script sc}:met, + metID:metID) + end; + + +(**. get pblIDs of all entries in mat3D .**) + + +fun format_pblID strl = enclose " [" "]" (commas_quote strl); +fun format_pblIDl strll = enclose "[\n" "\n]\n" + (space_implode ",\n" (map format_pblID strll)); + +fun scan _ [] = [] (* no base case, for empty doms only *) + | scan id ((Ptyp ((i,_,[])))::[]) = [id@[i]] + | scan id ((Ptyp ((i,_,pl)))::[]) = scan (id@[i]) pl + | scan id ((Ptyp ((i,_,[])))::ps) = [id@[i]] @(scan id ps) + | scan id ((Ptyp ((i,_,pl)))::ps) =(scan (id@[i]) pl)@(scan id ps); + +fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (!ptyps); +(* ptyps:=[]; + show_ptyps(); + *) +fun show_mets () = (writeln o format_pblIDl o (scan [])) (!mets); + + + +(*vvvvv---------- preparational work 8.01. UNUSED *) +(**+ instantiate a problem-type +**) + +(*+ transform oris +*) + +fun coll_vats (vats, ((_,vs,_,_,_):ori)) = union op = vats vs; +(*> coll_vats [11,22] (hd oris); +val it = [22,11,1,2,3] : int list + +> foldl coll_vats ([],oris); +val it = [1,2,3] : int list + +> val i=1; +> filter ((curry (op mem) i) o #2) oris; +val it = + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), + (2,[1,2,3],"#Find",Const (#,#),[Free #]), + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), + (6,[1],"#undef",Const (#,#),[Free #]), + (9,[1,2],"#undef",Const (#,#),[# $ #]), + (11,[1,2,3],"#undef",Const (#,#),[# $ #])] : ori list *) + +local infix mem; (*from Isabelle2002*) +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun filter_vat oris i = + filter ((curry (op mem) i) o (#2 : ori -> int list)) oris; +end; +(*> map (filter_vat oris) [1,2,3]; +val it = + [[(1,[1,2,3],"#Given",Const (#,#),[# $ #]), + (2,[1,2,3],"#Find",Const (#,#),[Free #]), + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), + (6,[1],"#undef",Const (#,#),[Free #]), + (9,[1,2],"#undef",Const (#,#),[# $ #]), + (11,[1,2,3],"#undef",Const (#,#),[# $ #])], + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), + (2,[1,2,3],"#Find",Const (#,#),[Free #]), + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), + (7,[2],"#undef",Const (#,#),[Free #]), + (9,[1,2],"#undef",Const (#,#),[# $ #]), + (11,[1,2,3],"#undef",Const (#,#),[# $ #])], + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), + (2,[1,2,3],"#Find",Const (#,#),[Free #]), + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), + (5,[3],"#Relate",Const (#,#),[# $ #,# $ #,# $ #]), + (8,[3],"#undef",Const (#,#),[Free #]), + (10,[3],"#undef",Const (#,#),[# $ #]), + (11,[1,2,3],"#undef",Const (#,#),[# $ #])]] : ori list list*) + +fun separate_vats oris = + let val vats = foldl coll_vats ([] : int list, oris); + in map (filter_vat oris) vats end; +(*^^^ end preparational work 8.01.*) + + + +(**. check a problem (ie. itm list) for matching a problemtype .**) + +fun eq1 d (_,(d',_)) = (d = d'); +fun itm_id ((i,_,_,_,_):itm) = i; +fun ori_id ((i,_,_,_,_):ori) = i; +fun ori2itmSup ((i,v,_,d,ts):ori) = ((i,v,true,"#Given",Sup(d,ts)):itm); +(*see + add_sel_ppc ~~~~~~~*) +fun field_eq f ((_,_,f',_,_):ori) = f = f'; + +(*. check an item (with arbitrary itm_ from previous matchings) + for matching a problemtype; returns true only for itms found in pbt .*) +fun chk_ thy pbt ((i,vats,b,f,Cor ((d,vs),_)):itm) = + (case find_first (eq1 d) pbt of + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), + (id, pbl_ids' thy d vs))):itm) + | NONE => (i,vats,false,f,Sup (d,vs))) + | chk_ thy pbt ((i,vats,b,f,Inc ((d,vs),_)):itm) = + (case find_first (eq1 d) pbt of + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), + (id, pbl_ids' thy d vs))):itm) + | NONE => (i,vats,false,f,Sup (d,vs))) + + | chk_ thy pbt (itm as (i,vats,b,f,Syn ct):itm) = itm + | chk_ thy pbt (itm as (i,vats,b,f,Typ ct):itm) = itm + + | chk_ thy pbt ((i,vats,b,f,Sup (d,vs)):itm) = + (case find_first (eq1 d) pbt of + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), + (id, pbl_ids' thy d vs))):itm) + | NONE => (i,vats,false,f,Sup (d,vs))) +(* val (i,vats,b,f,Mis (d,vs)) = i4; + *) + | chk_ thy pbt ((i,vats,b,f,Mis (d,vs)):itm) = + (case find_first (eq1 d) pbt of +(* val SOME (_,(_,id)) = find_first (eq1 d) pbt; + *) + SOME (_,(_,id)) => raise error "chk_: ((i,vats,b,f,Cor ((d,vs),\ + \(id, pbl_ids' d vs))):itm)" + | NONE => (i,vats,false,f,Sup (d,[vs]))); + +(* chk_ thy pbt i + *) + +fun eq2 (_,(d,_)) ((_,_,_,_,itm_):itm) = d = d_in itm_; +fun eq2' (_,(d,_)) ((_,_,_,d',_):ori) = d = d'; +fun eq0 ((0,_,_,_,_):itm) = true + | eq0 _ = false; +fun max_i i [] = i + | max_i i ((id,_,_,_,_)::is) = + if i > id then max_i i is else max_i id is; +fun max_id [] = 0 + | max_id ((id,_,_,_,_)::is) = max_i id is; +fun add_idvat itms _ _ [] = itms + | add_idvat itms i mvat (((_,_,b,f,itm_):itm)::its) = + add_idvat (itms @ [(i,[(*mvat ...meaningless with pbl-identifier *) + ],b,f,itm_):itm]) (i+1) mvat its; + + +(*. find elements of pbt not contained in itms; + if such one is untouched, return this one, otherwise create new itm .*) +fun chk_m (itms:itm list) untouched (p as (f,(d,id))) = + case find_first (eq2 p) itms of + SOME _ => [] + | NONE => (case find_first (eq2 p) untouched of + SOME itm => [itm] + | NONE => [(0,[],false,f,Mis (d,id)):itm]); +(* val itms = itms''; + *) +fun chk_mis mvat itms untouched pbt = + let val mis = (flat o (map (chk_m itms untouched))) pbt; + val mid = max_id itms; + in add_idvat [] (mid + 1) mvat mis end; + +(*. check a problem (ie. itm list) for matching a problemtype, + takes the max_vt for concluding completeness (could be another!) .*) +(* val itms = itms'; val (pbt,pre) = (ppc, pre); + val itms = itms; val (pbt,pre) = (ppc, pre); + *) +fun match_itms thy itms (pbt,pre,prls) = + (let fun okv mvat (_,vats,b,_,_) = member op = vats mvat + andalso b; + val itms' = map (chk_ thy pbt) itms; (*all found are #3 true*) + val mvat = max_vt itms'; + val itms'' = filter (okv mvat) itms'; + val untouched = filter eq0 itms;(*i.e. dsc only (from init)*) + val mis = chk_mis mvat itms'' untouched pbt; + val pre' = check_preconds' prls pre itms'' mvat + val pb = foldl and_ (true, map fst pre') + in (length mis = 0 andalso pb, (itms'@ mis, pre')) end); + +(*. check a problem pbl (ie. itm list) for matching a problemtype pbt, + for missing items get data from formalization (ie. ori list); + takes the max_vt for concluding completeness (could be another!) .*) +(* (0) determine the most frequent variant mv in pbl + ALL pbt. (1) dsc(pbt) notmem dsc(pbls) => + (2) filter (dsc(pbt) = dsc(oris)) oris; -> news; + (3) newitms = filter (mv mem vat(news)) news + (4) pbt @ newitms *) +(* val (pbl, pbt, pre) = (met, mtt, pre); + val (pbl, pbt, pre) = (itms, #ppc pbt, #where_ pbt); + val (pbl, pbt, pre) = (itms, ppc, where_); + *) +fun match_itms_oris thy (pbl:itm list) (pbt, pre, prls) oris = + let + (*0*)val mv = max_vt pbl; + + fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_; + fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of + SOME _ => false | NONE => true; + (*1*)val mis = (*(map (cons2 (fst, fst o snd)))o*) (filter (notmem pbl)) pbt; + + fun eqdsc_ori (_,(d,_)) ((_,_,_,d',_):ori) = d = d'; + fun ori2itmMis (f,(d,pid)) ((i,v,_,_,ts):ori) = + (i,v,false,f,Mis (d,pid)):itm; + (*2*)fun oris2itms oris mis1 = + ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris; + val news = (flat o (map (oris2itms oris))) mis; + (*3*)fun mem_vat (_,vats,b,_,_) = member op = vats mv; + val newitms = filter mem_vat news; + (*4*)val itms' = pbl @ newitms; + val pre' = check_preconds' prls pre itms' mv + val pb = foldl and_ (true, map fst pre') + in (length mis = 0 andalso pb, (itms', pre')) end; + (*handle _ => (false,([],[]))*); + + +(*vvv--- doubled 20.9.01: ... 7.3.02 itms --> oris, because oris + allow for faster access to descriptions and terms *) +(**. check a problem (ie. itm list) for matching a problemtype .**) + +(*. check an ori for matching a problemtype by description; + returns true only for itms found in pbt .*) +fun chk1_ thy pbt ((i,vats,f,d,vs):ori) = + case find_first (eq1 d) pbt of + SOME (_,(_,id)) => [(i,vats,true,f, + Cor ((d,vs), (id, pbl_ids' thy d vs))):itm] + | NONE => []; + +(* elem 'p' of pbt contained in itms ? *) +fun chk1_m (itms:itm list) p = + case find_first (eq2 p) itms of + SOME _ => true | NONE => false; +fun chk1_m' (oris: ori list) (p as (f,(d,t))) = + case find_first (eq2' p) oris of + SOME _ => [] + | NONE => [(f, Mis (d, t))]; +fun pair0vatsfalse (f,itm_) = (0,[],false,f,itm_):itm; + +fun chk1_mis mvat itms ppc = foldl and_ (true, map (chk1_m itms) ppc); +fun chk1_mis' oris ppc = + map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc); + + +(*. check a problem (ie. ori list) for matching a problemtype, + takes the max_vt for concluding completeness (FIXME could be another!) .*) +(* val (prls,oris,pbt,pre)=(#prls py, ori, #ppc py, #where_ py); + *) +fun match_oris thy prls oris (pbt,pre) = + let val itms = (flat o (map (chk1_ thy pbt))) oris; + val mvat = max_vt itms; + val complete = chk1_mis mvat itms pbt; + val pre' = check_preconds' prls pre itms mvat + val pb = foldl and_ (true, map fst pre') + in if complete andalso pb then true else false end; +(*run subp-rooteq.sml 'root-eq + subpbl: solve_linear' + until 'val nxt = ("Model_Problem",Model_Problem ["linear","univariate"... +> val Nd(PblObj _,[_,_,_,_,_,_,_,_,_,_,_, + Nd(PblObj{origin=(oris,_,_),...},[])]) = pt; +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"], + (#where_ o get_pbt) ["linear","univariate","equation"]); +> match_oris oris (pbt,pre); +val it = true : bool + + +> val (pbt,pre) =((#ppc o get_pbt) ["plain_square","univariate","equation"], + (#where_ o get_pbt)["plain_square","univariate","equation"]); +> match_oris oris (pbt,pre); +val it = false : bool + + + --------------------------------------------------- + run subp-rooteq.sml 'root-eq + subpbl: solve_plain_square' + until 'val nxt = ("Model_Problem",Model_Problem ["plain_square","univ... +> val Nd (PblObj _, [_,_,_,_,_,_,_,Nd (PrfObj _,[]), + Nd (PblObj {origin=(oris,_,_),...},[])]) = pt; +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"], + (#where_ o get_pbt) ["linear","univariate","equation"]); +> match_oris oris (pbt,pre); +val it = false : bool + + +> val (pbt,pre)=((#ppc o get_pbt) ["plain_square","univariate","equation"], + (#where_ o get_pbt) ["plain_square","univariate","equation"]); +> match_oris oris (pbt,pre); +val it = true : bool +*) +(*^^^--- doubled 20.9.01 *) + + +(*. check a problem (ie. ori list) for matching a problemtype, + returns items for output to math-experts .*) +(* val (ppc,pre) = (#ppc py, #where_ py); + *) +fun match_oris' thy oris (ppc,pre,prls) = +(* val (thy, oris, (ppc,pre,prls)) = (thy, oris, (ppc, where_, prls)); + *) + let val itms = (flat o (map (chk1_ thy ppc))) oris; + val sups = ((map ori2itmSup) o (filter(field_eq "#undef")))oris; + val mvat = max_vt itms; + val miss = chk1_mis' oris ppc; + val pre' = check_preconds' prls pre itms mvat + val pb = foldl and_ (true, map fst pre') + in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end; + +(*. for the user .*) +datatype match' = + Matches' of item ppc +| NoMatch' of item ppc; + +(*. match a formalization with a problem type .*) +fun match_pbl (fmz:fmz_) ({thy=thy,where_=pre,ppc,prls=er,...}:pbt) = + let val oris = prep_ori fmz thy ppc; + val (bool, (itms, pre')) = match_oris' thy oris (ppc,pre,er); + in if bool then Matches' (itms2itemppc thy itms pre') + else NoMatch' (itms2itemppc thy itms pre') end; +(* +val fmz = ["equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))", + "solveFor x","errorBound (eps=0)","solutions L"]; +val pbt as {thy = thy, where_ = pre, ppc = ppc,...} = + get_pbt ["univariate","equation"]; +match_pbl fmz pbt; +*) + + +(*. refine a problem; construct pblRD while scanning .*) +(* val (pblRD,ori)=("xxx",oris); + val py = get_pbt ["equation"]; + val py = get_pbt ["univariate","equation"]; + val py = get_pbt ["linear","univariate","equation"]; + val py = get_pbt ["root","univariate","equation"]; + match_oris (#prls py) ori (#ppc py, #where_ py); + + *) +fun refin (pblRD:pblRD) ori +((Ptyp (pI,[py],[])):pbt ptyp) = + if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) + then SOME ((pblRD @ [pI]):pblRD) + else NONE + | refin pblRD ori (Ptyp (pI,[py],pys)) = + if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) + then (case refins (pblRD @ [pI]) ori pys of + SOME pblRD' => SOME pblRD' + | NONE => SOME (pblRD @ [pI])) + else NONE +and refins pblRD ori [] = NONE + | refins pblRD ori ((p as Ptyp (pI,_,_))::pts) = + (case refin pblRD ori p of + SOME pblRD' => SOME pblRD' + | NONE => refins pblRD ori pts); + +(*. refine a problem; version providing output for math-experts .*) +fun refin' (pblRD:pblRD) fmz pbls ((Ptyp (pI,[py],[])):pbt ptyp) = +(* val ((pblRD:pblRD), fmz, pbls, ((Ptyp (pI,[py],[])):pbt ptyp)) = + (rev ["linear","system"], fmz, [(*match list*)], + ((Ptyp ("2x2",[get_pbt ["2x2","linear","system"]],[])):pbt ptyp)); + *) + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str)(pblRD @ [pI]) + val {thy,ppc,where_,prls,...} = py + val oris = prep_ori fmz thy ppc + (*8.3.02: itms!: oris ev. are _not_ complete here*) + val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls) + in if b then pbls @ [Matches (rev (pblRD @ [pI]), + itms2itemppc thy itms pre')] + else pbls @ [NoMatch (rev (pblRD @ [pI]), + itms2itemppc thy itms pre')] + end +(* val pblRD = ["pbla"]; val fmz = fmz1; val pbls = []; + val Ptyp (pI,[py],pys) = hd (!ptyps); + refin' pblRD fmz pbls (Ptyp (pI,[py],pys)); +*) + | refin' pblRD fmz pbls (Ptyp (pI,[py],pys)) = + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str) (pblRD @ [pI]) + val {thy,ppc,where_,prls,...} = py + val oris = prep_ori fmz thy ppc; + (*8.3.02: itms!: oris ev. are _not_ complete here*) + val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls); + in if b + then let val pbl = Matches (rev (pblRD @ [pI]), + itms2itemppc thy itms pre') + in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end + else (pbls @ [NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')]) + end +and refins' pblRD fmz pbls [] = pbls + | refins' pblRD fmz pbls ((p as Ptyp (pI,_,_))::pts) = + let val pbls' = refin' pblRD fmz pbls p + in case last_elem pbls' of + Matches _ => pbls' + | NoMatch _ => refins' pblRD fmz pbls' pts end; + +(*. refine a problem; version for tactic Refine_Problem .*) +fun refin'' thy (pblRD:pblRD) itms pbls ((Ptyp (pI,[py],[])):pbt ptyp) = + let (*val _ = writeln("### refin''1: pI="^pI);*) + val {thy,ppc,where_,prls,...} = py + val (b, (itms', pre')) = match_itms thy itms (ppc,where_,prls); + in if b then pbls @ [Match_ (rev (pblRD @ [pI]), (itms', pre'))] + else pbls @ [NoMatch_] + end +(* val pblRD = (rev o tl) pblID; val pbls = []; + val Ptyp (pI,[py],pys) = app_ptyp I pblID (rev pblID) (!ptyps); + *) + | refin'' thy pblRD itms pbls (Ptyp (pI,[py],pys)) = + let (*val _ = writeln("### refin''2: pI="^pI);*) + val {thy,ppc,where_,prls,...} = py + val(b, (itms', pre')) = match_itms thy itms (ppc,where_,prls); + in if b + then let val pbl = Match_ (rev (pblRD @ [pI]), (itms', pre')) + in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end + else (pbls @ [NoMatch_]) + end +and refins'' thy pblRD itms pbls [] = pbls + | refins'' thy pblRD itms pbls ((p as Ptyp (pI,_,_))::pts) = + let val pbls' = refin'' thy pblRD itms pbls p + in case last_elem pbls' of + Match_ _ => pbls' + | NoMatch_ => refins'' thy pblRD itms pbls' pts end; + + +(*. apply a fun to a ptyps node; copied from get_py .*) +fun app_ptyp f (d:pblID) _ [] = + raise error ("app_ptyp not found: "^(strs2str d)) + | app_ptyp f d (k::[]) ((p as Ptyp (k',[py],_))::pys) = + if k=k' then f p + else app_ptyp f d ([k]:pblRD) pys + | app_ptyp f d (k::ks) ((Ptyp (k',_,pys))::pys') = + if k=k' then app_ptyp f d ks pys + else app_ptyp f d (k::ks) pys'; + +(*. for tactic Refine_Tacitly .*) +(*!!! oris are already created wrt. some pbt; pbt contains thy for parsing*) +(* val (thy,pblID) = (assoc_thy dI',pI); + *) +fun refine_ori oris (pblID:pblID) = + let val opt = app_ptyp (refin ((rev o tl) pblID) oris) + pblID (rev pblID) (!ptyps); + in case opt of + SOME pblRD => let val (pblID':pblID) =(rev pblRD) + in if pblID' = pblID then NONE + else SOME pblID' end + | NONE => NONE end; +fun refine_ori' oris pI = (the (refine_ori oris pI)) handle _ => pI; + +(*. for tactic Refine_Problem .*); +(* 10.03: returnvalue -> (pIrefined, itm list) would be sufficient *) +(* val pblID = pI; app_ptyp I pblID (rev pblID) (!ptyps); + *) +fun refine_pbl thy (pblID:pblID) itms = + case refined_ (app_ptyp (refin'' thy ((rev o tl) pblID) itms []) + pblID (rev pblID) (!ptyps)) of + NONE => NONE + | SOME (Match_ (rfd as (pI',_))) => + if pblID = pI' then NONE else SOME rfd; + + +(*. for math-experts .*) +(*19.10.02FIXME: needs thy for parsing fmz*) +(* val fmz = fmz1; val pblID = ["pbla"]; val pblRD = (rev o tl) pblID; + val pbls = []; val ptys = !ptyps; + *) +fun refine (fmz:fmz_) (pblID:pblID) = + app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID) (!ptyps); + + +(*.make a guh from a reference to an element in the kestore; + EXCEPT theory hierarchy ... compare 'fun keref2xml'.*) +fun pblID2guh (pblID:pblID) = + (((#guh o get_pbt) pblID) + handle _ => raise error ("pblID2guh: not for '"^strs2str' pblID ^ "'")); +fun metID2guh (metID:metID) = + (((#guh o get_met) metID) + handle _ => raise error ("metID2guh: no 'Met_' for '"^ + strs2str' metID ^ "'")); +fun kestoreID2guh Pbl_ (kestoreID:kestoreID) = pblID2guh kestoreID + | kestoreID2guh Met_ (kestoreID:kestoreID) = metID2guh kestoreID + | kestoreID2guh ketype kestoreID = + raise error ("kestoreID2guh: '" ^ ketype2str ketype ^ "' not for '" ^ + strs2str' kestoreID ^ "'"); + +fun show_pblguhs () = + (print_depth 999; + (writeln o strs2str o (map linefeed)) (coll_pblguhs (!ptyps)); + print_depth 3); +fun sort_pblguhs () = + (print_depth 999; + (writeln o strs2str o (map linefeed)) + (((sort string_ord) o coll_pblguhs) (!ptyps)); + print_depth 3); + +fun show_metguhs () = + (print_depth 999; + (writeln o strs2str o (map linefeed)) (coll_metguhs (!mets)); + print_depth 3); +fun sort_metguhs () = + (print_depth 999; + (writeln o strs2str o (map linefeed)) + (((sort string_ord) o coll_metguhs) (!mets)); + print_depth 3); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/rewtools.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/rewtools.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,845 @@ +(* tools for rewriting, reverse rewriting, context to thy concerning rewriting + authors: Walther Neuper 2002, 2006 + (c) due to copyright terms + +use"ME/rewtools.sml"; +use"rewtools.sml"; +*) + + + +(***.reverse rewriting.***) + +(*.derivation for insertin one level of nodes into the calctree.*) +type deriv = (term * rule * (term *term list)) list; + +fun trta2str (t,r,(t',a)) = "\n("^(term2str t)^", "^(rule2str' r)^", ("^ + (term2str t')^", "^(terms2str a)^"))"; +fun trtas2str trtas = (strs2str o (map trta2str)) trtas; +val deriv2str = trtas2str; +fun rta2str (r,(t,a)) = "\n("^(rule2str' r)^", ("^ + (term2str t)^", "^(terms2str a)^"))"; +fun rtas2str rtas = (strs2str o (map rta2str)) rtas; +val deri2str = rtas2str; + + +(*.A1==>...==>An==>(Lhs = Rhs) goes to A1==>...==>An==>(Rhs = Lhs).*) +fun sym_thm thm = + let + val (deriv, {thy_ref = thy_ref, tags = tags, maxidx = maxidx, + shyps = shyps, hyps = hyps, tpairs = tpairs, + prop = prop}) = + rep_thm_G thm; + val (lhs,rhs) = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) prop; + val prop' = case strip_imp_prems' prop of + NONE => Trueprop $ (mk_equality (rhs, lhs)) + | SOME cs => + ins_concl cs (Trueprop $ (mk_equality (rhs, lhs))); + in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end; +(* + (sym RS real_mult_div_cancel1) handle e => print_exn e; +Exception THM 1 raised: +RSN: no unifiers +"?s = ?t ==> ?t = ?s" +"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n" + + val thm = real_mult_div_cancel1; + val prop = (#prop o rep_thm) thm; + atomt prop; + val ppp = Logic.strip_imp_concl prop; + atomt ppp; + ((#prop o rep_thm o sym_thm o sym_thm) thm) = (#prop o rep_thm) thm; +val it = true : bool + ((sym_thm o sym_thm) thm) = thm; +val it = true : bool + + val thm = real_le_anti_sym; + ((sym_thm o sym_thm) thm) = thm; +val it = true : bool + + val thm = real_minus_zero; + ((sym_thm o sym_thm) thm) = thm; +val it = true : bool +*) + + + +(*.derive normalform of a rls, or derive until SOME goal, + and record rules applied and rewrites. +val it = fn + : theory + -> rls + -> rule list + -> rew_ord : the order of this rls, which 1 theorem of is used + for rewriting 1 single step (?14.4.03) + -> term option : 040214 ??? nonsense ??? + -> term + -> (term * : to this term ... + rule * : ... this rule is applied yielding ... + (term * : ... this term ... + term list)) : ... under these assumptions. + list : +returns empty list for a normal form +FIXME.WN040214: treats rules as in Rls, _not_ as in Seq + +WN060825 too complicated for the intended use by cancel_, common_nominator_ +and unreflectedly adapted to extion of rules by Rls_: returns Rls_("sym_simpl.. + -- replaced below*) +(* val (thy, erls, rs, ro, goal, tt) = (thy, erls, rs, ro, goal, t); + val (thy, erls, rs, ro, goal, tt) = (thy, Atools_erls, rules, ro, NONE, tt); + *) +fun make_deriv thy erls (rs:rule list) ro(*rew_ord*) goal tt = + let datatype switch = Appl | Noap + fun rew_once lim rts t Noap [] = + (case goal of + NONE => rts + | SOME g => + raise error ("make_deriv: no derivation for "^(term2str t))) + | rew_once lim rts t Appl [] = + (*(case rs of Rls _ =>*) rew_once lim rts t Noap rs + (*| Seq _ => rts) FIXXXXXME 14.3.03*) + | rew_once lim rts t apno rs' = + (case goal of + NONE => rew_or_calc lim rts t apno rs' + | SOME g => + if g = t then rts + else rew_or_calc lim rts t apno rs') + and rew_or_calc lim rts t apno (rrs' as (r::rs')) = + if lim < 0 + then (writeln ("make_deriv exceeds " ^ int2str (!lim_deriv) ^ + "with deriv =\n"); writeln (deriv2str rts); rts) + else + case r of + Thm (thmid, tm) => + (if not (!trace_rewrite) then () else + writeln ("### trying thm '" ^ thmid ^ "'"); + case rewrite_ thy ro erls true tm t of + NONE => rew_once lim rts t apno rs' + | SOME (t',a') => + (if ! trace_rewrite + then writeln ("### rewrites to: "^(term2str t')) else(); + rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs')) + | Calc (c as (op_,_)) => + let val _ = if not (!trace_rewrite) then () else + writeln ("### trying calc. '" ^ op_ ^ "'") + val t = uminus_to_string t + in case get_calculation_ thy c t of + NONE => rew_once lim rts t apno rs' + | SOME (thmid, tm) => + (let val SOME (t',a') = rewrite_ thy ro erls true tm t + val _ = if not (!trace_rewrite) then () else + writeln("### calc. to: " ^ (term2str t')) + val r' = Thm (thmid, tm) + in rew_once (lim-1) (rts@[(t,r',(t',a'))]) t' Appl rrs' + end) + handle _ => raise error "derive_norm, Calc: no rewrite" + end +(* TODO.WN080222: see rewrite__set_ + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + | Cal1 (cc as (op_,_)) => + (let val _= if !trace_rewrite andalso i < ! depth then + writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else (); + val ct = uminus_to_string ct + in case get_calculation_ thy cc ct of + NONE => (ct, asm) + | SOME (thmid, thm') => + let + val pairopt = + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) + ((#erls o rep_rls) rls) put_asm thm' ct; + val _ = if pairopt <> NONE then () + else raise error("rewrite_set_, rewrite_ \""^ + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") + val _ = if ! trace_rewrite andalso i < ! depth + then writeln((idt"="(i+1))^" cal1. to: "^ + (term2str ((fst o the) pairopt))) + else() + in the pairopt end + end) +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) + | Rls_ rls => + (case rewrite_set_ thy true rls t of + NONE => rew_once lim rts t apno rs' + | SOME (t',a') => + rew_once (lim-1) (rts @ [(t,r,(t',a'))]) t' Appl rrs'); +(*WN060829 | Rls_ rls => + (case rewrite_set_ thy true rls t of + NONE => rew_once lim rts t apno rs' + | SOME (t',a') => + if ro [] (t, t') then rew_once lim rts t apno rs' + else rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs'); +...lead to deriv = [] with make_polynomial. +THERE IS SOMETHING DIFFERENT beetween rewriting with the code above +and between rewriting with rewrite_set: with rules from make_polynomial and +t = "(a^^^2 + -1*b^^^2) / (a^^^2 + -2*a*b + b^^^2)" the actual code +leads to cycling Rls_ order_mult_rls_..Rls_ discard_parentheses_..Rls_ order.. +*) + in rew_once (!lim_deriv) [] tt Noap rs end; + + +(*.toggles the marker for 'fun sym_thm'.*) +fun sym_thmID (thmID : thmID) = + case explode thmID of + "s"::"y"::"m"::"_"::id => implode id : thmID + | id => "sym_"^thmID; +(* +> val thmID = "sym_real_mult_2"; +> sym_thmID thmID; +val it = "real_mult_2" : string +> val thmID = "real_num_collect"; +> sym_thmID thmID; +val it = "sym_real_num_collect" : string*) +fun sym_drop (thmID : thmID) = + case explode thmID of + "s"::"y"::"m"::"_"::id => implode id : thmID + | id => thmID; +fun is_sym (thmID : thmID) = + case explode thmID of + "s"::"y"::"m"::"_"::id => true + | id => false; + + +(*FIXXXXME.040219: detail has to handle Rls id="sym_..." + by applying make_deriv, rev_deriv'; see concat_deriv*) +fun sym_rls Erls = Erls + | sym_rls (Rls {id, scr, calc, erls, srls, rules, rew_ord, preconds}) = + Rls {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls, + rules=rules, rew_ord=rew_ord, preconds=preconds} + | sym_rls (Seq {id, scr, calc, erls, srls, rules, rew_ord, preconds}) = + Seq {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls, + rules=rules, rew_ord=rew_ord, preconds=preconds} + | sym_rls (Rrls {id, scr, calc, erls, prepat, rew_ord}) = + Rrls {id="sym_"^id, scr=scr, calc=calc, erls=erls, prepat=prepat, + rew_ord=rew_ord}; + +fun sym_Thm (Thm (thmID, thm)) = Thm (sym_thmID thmID, sym_thm thm) + | sym_Thm (Rls_ rls) = Rls_ (*WN060825?!?*) (sym_rls rls) + | sym_Thm r = raise error ("sym_Thm: not for "^(rule2str r)); +(* + val th = Thm ("real_one_collect",num_str real_one_collect); + sym_Thm th; +val th = + Thm ("real_one_collect","?m is_const ==> ?n + ?m * ?n = (1 + ?m) * ?n") + : rule +ML> val it = + Thm ("sym_real_one_collect","?m is_const ==> (1 + ?m) * ?n = ?n + ?m * ?n")*) + + +(*version for reverse rewrite used before 040214*) +fun rev_deriv (t, r, (t', a)) = (sym_Thm r, (t, a)); +(* val (thy, erls, rs, ro, goal, t) = (thy, eval_rls, rules, ro, NONE, t'); + *) +fun reverse_deriv thy erls (rs:rule list) ro(*rew_ord*) goal t = + (rev o (map rev_deriv)) (make_deriv thy erls (rs:rule list) ro goal t); +(* + val rev_rew = reverse_deriv thy e_rls ; + writeln(rtas2str rev_rew); +*) + +fun eq_Thm (Thm (id1,_), Thm (id2,_)) = id1 = id2 + | eq_Thm (Thm (id1,_), _) = false + | eq_Thm (Rls_ r1, Rls_ r2) = id_rls r1 = id_rls r2 + | eq_Thm (Rls_ r1, _) = false + | eq_Thm (r1, r2) = raise error ("eq_Thm: called with '"^ + (rule2str r1)^"' '"^(rule2str r2)^"'"); +fun distinct_Thm r = gen_distinct eq_Thm r; + +fun eq_Thms thmIDs thm = (member op = thmIDs (id_of_thm thm)) + handle _ => false; + + +(***. context to thy concerning rewriting .***) + +(*.create the unique handles and filenames for the theory-data.*) +fun part2guh ([str]:theID) = + (case str of + "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh + | "IsacScripts" => "thy_scri_" ^ str ^ "-part" + | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part" + | str => raise error ("thy2guh: called with '"^str^"'")) + | part2guh theID = raise error ("part2guh called with theID = " + ^ theID2str theID); +fun part2filename str = part2guh str ^ ".xml" : filename; + + +fun thy2guh ([part, thyID]:theID) = + (case part of + "Isabelle" => "thy_isab_" ^ thyID : guh + | "IsacScripts" => "thy_scri_" ^ thyID + | "IsacKnowledge" => "thy_isac_" ^ thyID + | str => raise error ("thy2guh: called with '"^str^"'")) + | thy2guh theID = raise error ("thy2guh called with '"^strs2str' theID^"'"); +fun thy2filename thy' = thy2guh thy' ^ ".xml" : filename; +fun thypart2guh ([part, thyID, thypart]:theID) = + case part of + "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh + | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart + | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart + | str => raise error ("thypart2guh: called with '"^str^"'"); +fun thypart2filename thy' = thypart2guh thy' ^ ".xml" : filename; + +(*.convert the data got via contextToThy to a globally unique handle + there is another way to get the guh out of the 'theID' in the hierarchy.*) +fun thm2guh (isa, thyID:thyID) (thmID:thmID) = + case isa of + "Isabelle" => + "thy_isab_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh + | "IsacKnowledge" => + "thy_isac_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID + | "IsacScripts" => + "thy_scri_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID + | str => raise error ("thm2guh called with isa = '"^isa^ + "' for thm = "^thmID^"'"); +fun thm2filename (isa_thyID: string * thyID) thmID = + (thm2guh isa_thyID thmID) ^ ".xml" : filename; + +fun rls2guh (isa, thyID:thyID) (rls':rls') = + case isa of + "Isabelle" => + "thy_isab_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' : guh + | "IsacKnowledge" => + "thy_isac_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' + | "IsacScripts" => + "thy_scri_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' + | str => raise error ("rls2guh called with isa = '"^isa^ + "' for rls = '"^rls'^"'"); + fun rls2filename (isa, thyID) rls' = + rls2guh (isa, thyID) rls' ^ ".xml" : filename; + +fun cal2guh (isa, thyID:thyID) calID = + case isa of + "Isabelle" => + "thy_isab_" ^ theory'2thyID thyID ^ "-cal-" ^ calID : guh + | "IsacKnowledge" => + "thy_isac_" ^ theory'2thyID thyID ^ "-cal-" ^ calID + | "IsacScripts" => + "thy_scri_" ^ theory'2thyID thyID ^ "-cal-" ^ calID + | str => raise error ("cal2guh called with isa = '"^isa^ + "' for cal = '"^calID^"'"); +fun cal2filename (isa, thyID:thyID) calID = + cal2guh (isa, thyID:thyID) calID ^ ".xml" : filename; + +fun ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') = + case isa of + "Isabelle" => + "thy_isab_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh + | "IsacKnowledge" => + "thy_isac_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' + | "IsacScripts" => + "thy_scri_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' + | str => raise error ("ord2guh called with isa = '"^isa^ + "' for ord = '"^rew_ord'^"'"); +fun ord2filename (isa, thyID:thyID) (rew_ord':rew_ord') = + ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') ^ ".xml" : filename; + + +(**.set up isab_thm_thy in Isac.ML.**) + +fun rearrange (thyID, (thmID, thm)) = (thmID, (thyID, thm)); +fun rearrange_inv (thmID, (thyID, thm)) = (thyID, (thmID, thm)); + +(*.lookup the missing theorems in some thy (of Isabelle).*) +fun make_isa missthms thy = + map (pair (theory2thyID thy)) + ((inter eq_thmI) missthms (PureThy.all_thms_of thy)) + : (thyID * (thmID * Thm.thm)) list; + +(*.separate handling of sym_thms.*) +fun make_isab rlsthmsNOTisac isab_thys = + let fun les ((s1,_), (s2,_)) = (s1 : string) < s2 + val notsym = filter_out (is_sym o #1) rlsthmsNOTisac + val notsym_isab = (flat o (map (make_isa notsym))) isab_thys + + val sym = filter (is_sym o #1) rlsthmsNOTisac + + val symsym = map ((apfst sym_drop) o (apsnd sym_thm)) sym + val symsym_isab = (flat o (map (make_isa symsym))) isab_thys + + val sym_isab = map (((apsnd o apfst) sym_drop) o + ((apsnd o apsnd) sym_thm)) symsym_isab + + val isab = notsym_isab @ symsym_isab @ sym_isab + in ((map rearrange) o (gen_sort les)) isab + : (thmID * (thyID * Thm.thm)) list + end; + +(*.which theory below thy' contains a theorem; this can be in isabelle ! +get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*) +(* val (str, (_, thy)) = ("real_diff_minus", ("Root.thy", Root.thy)); + val (str, (_, thy)) = ("real_diff_minus", ("Poly.thy", Poly.thy)); + *) +fun thy_contains_thm (str:xstring) (_, thy) = + member op = (map (strip_thy o fst) (PureThy.all_thms_of thy)) str; +(* val (thy', str) = ("Isac.thy", "real_mult_minus1"); + val (thy', str) = ("PolyMinus.thy", "klammer_minus_plus"); + *) +fun thy_containing_thm (thy':theory') (str:xstring) = + let val thy' = thyID2theory' thy' + val str = sym_drop str + val startsearch = dropuntil ((curry op= thy') o + (#1:theory' * theory -> theory')) + (rev (!theory')) + in case find_first (thy_contains_thm str) startsearch of + SOME (thy',_) => ("IsacKnowledge", thy') + | NONE => (case assoc (!isab_thm_thy (*see Isac.ML*), str) of + SOME (thyID,_) => ("Isabelle", thyID) + | NONE => + raise error ("thy_containing_thm: theorem '"^str^ + "' not in !theory' above thy '"^thy'^"'")) + end; + + +(*.which theory below thy' contains a ruleset; +get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*) +(* val (thy', rls') = ("PolyEq.thy", "separate_bdv"); + *) +local infix mem; (*from Isabelle2002*) +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +in +fun thy_containing_rls (thy':theory') (rls':rls') = + let val rls' = strip_thy rls' + val thy' = thyID2theory' thy' + (*take thys between "Isac" and thy' not to search #1#*) + val dropthys = takewhile [] (not o (curry op= thy') o + (#1:theory' * theory -> theory')) + (rev (!theory')) + val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory')) + dropthys + (*drop those rulesets which are generated in a theory found in #1#*) + val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o + ((#1 o #2) : rls' * (theory' * rls) + -> theory')) + (rev (!ruleset')) + in case assoc (startsearch, rls') of + SOME (thy', _) => ("IsacKnowledge", thyID2theory' thy') + | _ => raise error ("thy_containing_rls : rls '"^rls'^ + "' not in !rulset' above thy '"^thy'^"'") + end; +(* val (thy', termop) = (thyID, termop); + *) +fun thy_containing_cal (thy':theory') termop = + let val thy' = thyID2theory' thy' + val dropthys = takewhile [] (not o (curry op= thy') o + (#1:theory' * theory -> theory')) + (rev (!theory')) + val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory')) + dropthys + val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o + (#1 : calc -> string)) (rev (!calclist')) + in case assoc (startsearch, strip_thy termop) of + SOME (th_termop, _) => ("IsacKnowledge", strip_thy th_termop) + | _ => raise error ("thy_containing_rls : rls '"^termop^ + "' not in !calclist' above thy '"^thy'^"'") + end +end; + +(* print_depth 99; map #1 startsearch; print_depth 3; + *) + +(*.packing return-values to matchTheory, contextToThy for xml-generation.*) +datatype contthy = (*also an item from KEStore on Browser ......#*) + EContThy (*not from KEStore ...........................*) + | ContThm of (*a theorem in contex =============*) + {thyID : thyID, (*for *2guh in sub-elems here .*) + thm : guh, (*theorem in the context .*) + applto : term, (*applied to formula ... .*) + applat : term, (*... with lhs inserted .*) + reword : rew_ord', (*order used for rewrite .*) + asms : (term (*asumption instantiated .*) + * term) list, (*asumption evaluated .*) + lhs : term (*lhs of the theorem ... #*) + * term, (*... instantiated .*) + rhs : term (*rhs of the theorem ... #*) + * term, (*... instantiated .*) + result : term, (*resulting from the rewrite .*) + resasms : term list, (*... with asms stored .*) + asmrls : rls' (*ruleset for evaluating asms .*) + } + | ContThmInst of (*a theorem with bdvs in contex ======== *) + {thyID : thyID, (*for *2guh in sub-elems here .*) + thm : guh, (*theorem in the context .*) + bdvs : subst, (*bound variables to modify....*) + thminst : term, (*... theorem instantiated .*) + applto : term, (*applied to formula ... .*) + applat : term, (*... with lhs inserted .*) + reword : rew_ord', (*order used for rewrite .*) + asms : (term (*asumption instantiated .*) + * term) list, (*asumption evaluated .*) + lhs : term (*lhs of the theorem ... #*) + * term, (*... instantiated .*) + rhs : term (*rhs of the theorem ... #*) + * term, (*... instantiated .*) + result : term, (*resulting from the rewrite .*) + resasms : term list, (*... with asms stored .*) + asmrls : rls' (*ruleset for evaluating asms .*) + } + | ContRls of (*a rule set in contex ===================== *) + {thyID : thyID, (*for *2guh in sub-elems here .*) + rls : guh, (*rule set in the context .*) + applto : term, (*rewrite this formula .*) + result : term, (*resulting from the rewrite .*) + asms : term list (*... with asms stored .*) + } + | ContRlsInst of (*a rule set with bdvs in contex ======= *) + {thyID : thyID, (*for *2guh in sub-elems here .*) + rls : guh, (*rule set in the context .*) + bdvs : subst, (*for bound variables in thms .*) + applto : term, (*rewrite this formula .*) + result : term, (*resulting from the rewrite .*) + asms : term list (*... with asms stored .*) + } + | ContNOrew of (*no rewrite for thm or rls ============== *) + {thyID : thyID, (*for *2guh in sub-elems here .*) + thm_rls : guh, (*thm or rls in the context .*) + applto : term (*rewrite this formula .*) + } + | ContNOrewInst of (*no rewrite for some instantiation == *) + {thyID : thyID, (*for *2guh in sub-elems here .*) + thm_rls : guh, (*thm or rls in the context .*) + bdvs : subst, (*for bound variables in thms .*) + thminst : term, (*... theorem instantiated .*) + applto : term (*rewrite this formula .*) + }; + +(*.check a rewrite-tac for bdv (RL always used *_Inst !) TODO.WN060718 + pass other tacs unchanged.*) +fun get_tac_checked pt ((p,p_) : pos') = get_obj g_tac pt p; + +(*..*) + + + +(*.get the formula f at ptp rewritten by the Rewrite_* already applied to f.*) +(* val (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) = tac'; + *) +fun context_thy (pt, pos as (p,p_)) (tac as Rewrite (thmID,_)) = + (case applicable_in pos pt tac of + Appl (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) => + let val thy = assoc_thy thy' + val thm = (norm o #prop o rep_thm o (PureThy.get_thm thy)) thmID + (*WN060616 the following must be done on subterm found _IN_ rew_sub + val (lhs,rhs) = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) thm + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f) + val thm' = ren_inst (insts, thm, lhs, f) + val (lhs',rhs') = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) thm' + val asms = map strip_trueprop (Logic.strip_imp_prems thm) + val asms' = map strip_trueprop (Logic.strip_imp_prems thm') + *) + in ContThm {thyID = theory'2thyID thy', + thm = thm2guh (thy_containing_thm thy' thmID) thmID, + applto = f, + applat = e_term, + reword = ord', + asms = [](*asms ~~ asms'*), + lhs = (e_term, e_term)(*(lhs, lhs')*), + rhs = (e_term, e_term)(*(rhs, rhs')*), + result = res, + resasms = asm, + asmrls = id_rls erls} + end + | Notappl _ => + let val pp = par_pblobj pt p + val thy' = get_obj g_domID pt pp + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + in ContNOrew {thyID = theory'2thyID thy', + thm_rls = thm2guh (thy_containing_thm thy' thmID) thmID, + applto = f} + end) + +(* val ((pt,p), tac as Rewrite_Inst (subs, (thmID,_))) = ((pt,pos), tac); + *) + | context_thy (pt, pos as (p,p_)) + (tac as Rewrite_Inst (subs, (thmID,_))) = + (case applicable_in pos pt tac of +(* val Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_), + f, (res,asm))) = applicable_in p pt tac; + *) + Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_), + f, (res,(*path to subterm,*)asm))) => + let val thm = (norm o #prop o rep_thm o + (PureThy.get_thm (assoc_thy thy'))) thmID + val thminst = inst_bdv subst thm + (*WN060616 the following must be done on subterm found _IN_ rew_sub + val (lhs,rhs) = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) thminst + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f) + val thm' = ren_inst (insts, thminst, lhs, f) + val (lhs',rhs') = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) thm' + val asms = map strip_trueprop (Logic.strip_imp_prems thminst) + val asms' = map strip_trueprop (Logic.strip_imp_prems thm') + *) + in ContThmInst {thyID = theory'2thyID thy', + thm = thm2guh (thy_containing_thm + thy' thmID) thmID, + bdvs = subst, + thminst = thminst, + applto = f, + applat = e_term, + reword = ord', + asms = [](*asms ~~ asms'*), + lhs = (e_term, e_term)(*(lhs, lhs')*), + rhs = (e_term, e_term)(*(rhs, rhs')*), + result = res, + resasms = asm, + asmrls = id_rls erls} + end + | Notappl _ => + let val pp = par_pblobj pt p + val thy' = get_obj g_domID pt pp + val subst = subs2subst (assoc_thy thy') subs + val thm = (norm o #prop o rep_thm o + (PureThy.get_thm (assoc_thy thy'))) thmID + val thminst = inst_bdv subst thm + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + in ContNOrewInst {thyID = theory'2thyID thy', + thm_rls = thm2guh (thy_containing_thm + thy' thmID) thmID, + bdvs = subst, + thminst = thminst, + applto = f} + end) + | context_thy (pt,p) (tac as Rewrite_Set rls') = + (case applicable_in p pt tac of + Appl (Rewrite_Set' (thy', _, rls, f, (res,asm))) => + ContRls {thyID = theory'2thyID thy', + rls = rls2guh (thy_containing_rls thy' rls') rls', + applto = f, + result = res, + asms = asm}) + | context_thy (pt,p) (tac as Rewrite_Set_Inst (subs, rls')) = + (case applicable_in p pt tac of + Appl (Rewrite_Set_Inst' (thy', _, subst, rls, f, (res,asm))) => + ContRlsInst {thyID = theory'2thyID thy', + rls = rls2guh (thy_containing_rls thy' rls') rls', + bdvs = subst, + applto = f, + result = res, + asms = asm}); + +(*.get all theorems in a rule set (recursivley containing rule sets).*) +fun thm_of_rule Erule = [] + | thm_of_rule (thm as Thm _) = [thm] + | thm_of_rule (Calc _) = [] + | thm_of_rule (Cal1 _) = [] + | thm_of_rule (Rls_ rls) = thms_of_rls rls +and thms_of_rls Erls = [] + | thms_of_rls (Rls {rules,...}) = (flat o (map thm_of_rule)) rules + | thms_of_rls (Seq {rules,...}) = (flat o (map thm_of_rule)) rules + | thms_of_rls (Rrls _) = []; +(* val Hrls {thy_rls = (_, rls),...} = + get_the ["IsacKnowledge", "Test", "Rulesets", "expand_binomtest"]; +> thms_of_rls rls; + *) + +(*. check if a rule is contained in a rule-set (recursivley down in Rls_); + this rule can even be a rule-set itself.*) +fun contains_rule r rls = + let fun find (r, Rls_ rls) = finds (get_rules rls) + | find r12 = eq_rule r12 + and finds [] = false + | finds (r1 :: rs) = if eq_rule (r, r1) then true else finds rs; + in + (*writeln ("### contains_rule: r = "^rule2str r^", rls = "^rls2str rls);*) + finds (get_rules rls) + end; + +(*. try if a rewrite-rule is applicable to a given formula; + in case of rule-sets (recursivley) collect all _atomic_ rewrites .*) +fun try_rew thy ((_, ro):rew_ord) erls (subst:subst) f (thm' as Thm(id, thm)) = + if contains_bdv thm + then case rewrite_inst_ thy ro erls false subst thm f of + SOME (f',_) =>[rule2tac subst thm'] + | NONE => [] + else (case rewrite_ thy ro erls false thm f of + SOME (f',_) => [rule2tac [] thm'] + | NONE => []) + | try_rew thy _ _ _ f (cal as Calc c) = + (case get_calculation_ thy c f of + SOME (str, _) => [rule2tac [] cal] + | NONE => []) + | try_rew thy _ _ _ f (cal as Cal1 c) = + (case get_calculation_ thy c f of + SOME (str, _) => [rule2tac [] cal] + | NONE => []) + | try_rew thy _ _ subst f (Rls_ rls) = filter_appl_rews thy subst f rls +and filter_appl_rews thy subst f (Rls {rew_ord = ro, erls, rules,...}) = + distinct (flat (map (try_rew thy ro erls subst f) rules)) + | filter_appl_rews thy subst f (Seq {rew_ord = ro, erls, rules,...}) = + distinct (flat (map (try_rew thy ro erls subst f) rules)) + | filter_appl_rews thy subst f (Rrls _) = []; + +(*. decide if a tactic is applicable to a given formula; + in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*) +(* val + *) +fun atomic_appl_tacs thy _ _ f (Calculate scrID) = + try_rew thy e_rew_ordX e_rls [] f (Calc (snd(assoc1 (!calclist', scrID)))) + | atomic_appl_tacs thy ro erls f (Rewrite (thm' as (thmID, _))) = + try_rew thy (ro, assoc_rew_ord ro) erls [] f + (Thm (thmID, assoc_thm' thy thm')) + | atomic_appl_tacs thy ro erls f (Rewrite_Inst (subs, thm' as (thmID, _))) = + try_rew thy (ro, assoc_rew_ord ro) erls (subs2subst thy subs) f + (Thm (thmID, assoc_thm' thy thm')) + + | atomic_appl_tacs thy _ _ f (Rewrite_Set rls') = + filter_appl_rews thy [] f (assoc_rls rls') + | atomic_appl_tacs thy _ _ f (Rewrite_Set_Inst (subs, rls')) = + filter_appl_rews thy (subs2subst thy subs) f (assoc_rls rls') + | atomic_appl_tacs _ _ _ _ tac = + (writeln ("### atomic_appl_tacs: not impl. for tac = '"^ tac2str tac ^"'"); + []); + + + + + +(*.not only for thydata, but also for thy's etc.*) +fun theID2guh (theID:theID) = + case length theID of + 0 => raise error ("theID2guh: called with theID = "^strs2str' theID) + | 1 => part2guh theID + | 2 => thy2guh theID + | 3 => thypart2guh theID + | 4 => let val [isa, thyID, typ, elemID] = theID + in case typ of + "Theorems" => thm2guh (isa, thyID) elemID + | "Rulesets" => rls2guh (isa, thyID) elemID + | "Calculations" => cal2guh (isa, thyID) elemID + | "Orders" => ord2guh (isa, thyID) elemID + | "Theorems" => thy2guh [isa, thyID] + | str => raise error ("theID2guh: called with theID = "^ + strs2str' theID) + end + | n => raise error ("theID2guh called with theID = "^strs2str' theID); +(*.filenames not only for thydata, but also for thy's etc.*) +fun theID2filename (theID:theID) = theID2guh theID ^ ".xml" : filename; + +fun guh2theID (guh:guh) = + let val guh' = explode guh + val part = implode (take_fromto 1 4 guh') + val isa = implode (take_fromto 5 9 guh') + in if not (member op = ["exp_", "thy_", "pbl_", "met_"] part) + then raise error ("guh '"^guh^"' does not begin with \ + \exp_ | thy_ | pbl_ | met_") + else let val chap = case isa of + "isab_" => "Isabelle" + | "scri_" => "IsacScripts" + | "isac_" => "IsacKnowledge" + | _ => + raise error ("guh2theID: '"^guh^ + "' does not have isab_ | scri_ | \ + \isac_ at position 5..9") + val rest = takerest (9, guh') + val thyID = takewhile [] (not o (curry op= "-")) rest + val rest' = dropuntil (curry op= "-") rest + in case implode rest' of + "-part" => [chap] : theID + | "" => [chap, implode thyID] + | "-Theorems" => [chap, implode thyID, "Theorems"] + | "-Rulesets" => [chap, implode thyID, "Rulesets"] + | "-Operations" => [chap, implode thyID, "Operations"] + | "-Orders" => [chap, implode thyID, "Orders"] + | _ => + let val sect = implode (take_fromto 1 5 rest') + val sect' = + case sect of + "-thm-" => "Theorems" + | "-rls-" => "Rulesets" + | "-cal-" => "Operations" + | "-ord-" => "Orders" + | str => + raise error ("guh2theID: '"^guh^"' has '"^sect^ + "' instead -thm- | -rls- | \ + \-cal- | -ord-") + in [chap, implode thyID, sect', implode + (takerest (5, rest'))] + end + end + end; +(*> guh2theID "thy_isac_Biegelinie-Theorems"; +val it = ["IsacKnowledge", "Biegelinie", "Theorems"] : theID +> guh2theID "thy_scri_ListC-thm-zip_Nil"; +val it = ["IsacScripts", "ListC", "Theorems", "zip_Nil"] : theID*) + +fun guh2filename (guh : guh) = guh ^ ".xml" : filename; + + +(*..*) +fun guh2rewtac (guh:guh) ([] : subs) = + let val [isa, thy, sect, xstr] = guh2theID guh + in case sect of + "Theorems" => Rewrite (xstr, "") + | "Rulesets" => Rewrite_Set xstr + | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'") + end + | guh2rewtac (guh:guh) subs = + let val [isa, thy, sect, xstr] = guh2theID guh + in case sect of + "Theorems" => Rewrite_Inst (subs, (xstr, "")) + | "Rulesets" => Rewrite_Set_Inst (subs, xstr) + | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'") + end; +(*> guh2rewtac "thy_isac_Test-thm-constant_mult_square" []; +val it = Rewrite ("constant_mult_square", "") : tac +> guh2rewtac "thy_isac_Test-thm-risolate_bdv_add" ["(bdv, x)"]; +val it = Rewrite_Inst (["(bdv, x)"], ("risolate_bdv_add", "")) : tac +> guh2rewtac "thy_isac_Test-rls-Test_simplify" []; +val it = Rewrite_Set "Test_simplify" : tac +> guh2rewtac "thy_isac_Test-rls-isolate_bdv" ["(bdv, x)"]; +val it = Rewrite_Set_Inst (["(bdv, x)"], "isolate_bdv") : tac*) + + +(*.the front-end may request a context for any element of the hierarchy.*) +(* val guh = "thy_isac_Test-rls-Test_simplify"; + *) +fun no_thycontext (guh : guh) = (guh2theID guh; false) + handle _ => true; + +(*> has_thycontext "thy_isac_Test"; +if has_thycontext "thy_isac_Test" then "OK" else "NOTOK"; + *) + + + +(*.get the substitution of bound variables for matchTheory: + # lookup the thm|rls' in the script + # take the [(bdv, v_),..] from the respective Rewrite_(Set_)Inst + # instantiate this subs with the istates env to [(bdv, x),..] + # otherwise [].*) +(*WN060617 hack assuming that all scripts use only one bound variable +and use 'v_' as the formal argument for this bound variable*) +(* val (ScrState (env,_,_,_,_,_), _, guh) = (is, "dummy", guh); + *) +fun subs_from (ScrState (env,_,_,_,_,_)) _(*:Script sc*) (guh:guh) = + let val theID as [isa, thyID, sect, xstr] = guh2theID guh + in case sect of + "Theorems" => + let val thm = PureThy.get_thm (assoc_thy (thyID2theory' thyID)) xstr + in if contains_bdv thm + then let val formal_arg = str2term "v_" + val value = subst_atomic env formal_arg + in ["(bdv," ^ term2str value ^ ")"]:subs end + else [] + end + | "Rulesets" => + let val rules = (get_rules o assoc_rls) xstr + in if contain_bdv rules + then let val formal_arg = str2term"v_" + val value = subst_atomic env formal_arg + in ["(bdv,"^term2str value^")"]:subs end + else [] + end + end; + +(* use"ME/rewtools.sml"; + *) + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/script.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/script.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,2031 @@ +(* interpreter for scripts + (c) Walther Neuper 2000 + +use"ME/script.sml"; +use"script.sml"; +*) +signature INTERPRETER = +sig + (*type ets (list of executed tactics) see sequent.sml*) + + datatype locate + = NotLocatable + | Steps of (tac_ * mout * ptree * pos' * cid * safe (* ets*)) list +(* | ToDo of ets 28.4.02*) + + (*diss: next-tactic-function*) + val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> tac_ + (*diss: locate-function*) + val locate_gen : theory' + -> tac_ + -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate + + val sel_rules : ptree -> pos' -> tac list + val init_form : scr -> ets -> loc_ * term option (*FIXME not up to date*) + val formal_args : term -> term list + + (*shift to library ...*) + val inst_abs : theory' -> term -> term + val itms2args : metID -> itm list -> term list + val user_interrupt : loc_ * (tac_ * env * env * term * term * safe) + (*val empty : term*) +end + + + + +(* +structure Interpreter : INTERPRETER = +struct +*) + +(*.traces the leaves (ie. non-tactical nodes) of the script + found by next_tac. + a leaf is either a tactic or an 'exp' in 'let v = expr' + where 'exp' does not contain a tactic.*) +val trace_script = ref false; + +type step = (*data for creating a new node in the ptree; + designed for use: + fun ass* scrstate steps = + ... case ass* scrstate steps of + Assoc (scrstate, steps) => ... ass* scrstate steps*) + tac_ (*transformed from associated tac*) + * mout (*result with indentation etc.*) + * ptree (*containing node created by tac_ + resp. scrstate*) + * pos' (*position in ptree; ptree * pos' is the proofstate*) + * pos' list; (*of ptree-nodes probably cut (by fst tac_)*) +val e_step = (Empty_Tac_, EmptyMout, EmptyPtree, e_pos',[]:pos' list):step; + +fun rule2thm' (Thm (id, thm)) = (id, string_of_thmI thm):thm' + | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r)); +fun rule2rls' (Rls_ rls) = id_rls rls + | rule2rls' r = raise error ("rule2rls': not defined for "^(rule2str r)); + +(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve; + complicated with current t in rrlsstate.*) +fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] = + let val thy = assoc_thy thy' + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am)) + val is = RrlsState (f',f'',rss,rts) + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res) + val (p', cid, mout, pt') = generate1 thy m is p pt + in (is, (m, mout, pt', p', cid)::steps) end + | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) + ((r, (f', am))::rts') = + let val thy = assoc_thy thy' + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am)) + val is = RrlsState (f',f'',rss,rts) + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res) + val (p', cid, mout, pt') = generate1 thy m is p pt + in rts2steps ((m, mout, pt', p', cid)::steps) + ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end; + + +(*. functions for the environment stack .*) +fun accessenv id es = the (assoc((top es):env, id)) + handle _ => error ("accessenv: "^(free2str id)^" not in env"); +fun updateenv id vl (es:env stack) = + (push (overwrite(top es, (id, vl))) (pop es)):env stack; +fun pushenv id vl (es:env stack) = + (push (overwrite(top es, (id, vl))) es):env stack; +val popenv = pop:env stack -> env stack; + + + +fun de_esc_underscore str = + let fun scan [] = [] + | scan (s::ss) = if s = "'" then (scan ss) + else (s::(scan ss)) + in (implode o scan o explode) str end; +(* +> val str = "Rewrite_Set_Inst"; +> val esc = esc_underscore str; +val it = "Rewrite'_Set'_Inst" : string +> val des = de_esc_underscore esc; + val des = de_esc_underscore esc;*) + +(*go at a location in a script and fetch the contents*) +fun go [] t = t + | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0 + | go (L::p) (t1 $ t2) = go p t1 + | go (R::p) (t1 $ t2) = go p t2 + | go l _ = raise error ("go: no "^(loc_2str l)); +(* +> val t = (term_of o the o (parse thy)) "a+b"; +val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term +> val plus_a = go [L] t; +> val b = go [R] t; +> val plus = go [L,L] t; +> val a = go [L,R] t; + +> val t = (term_of o the o (parse thy)) "a+b+c"; +val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term +> val pl_pl_a_b = go [L] t; +> val c = go [R] t; +> val a = go [L,R,L,R] t; +> val b = go [L,R,R] t; +*) + + +(* get a subterm t with test t, and record location *) +fun get l test (t as Const (s,T)) = + if test t then SOME (l,t) else NONE + | get l test (t as Free (s,T)) = + if test t then SOME (l,t) else NONE + | get l test (t as Bound n) = + if test t then SOME (l,t) else NONE + | get l test (t as Var (s,T)) = + if test t then SOME (l,t) else NONE + | get l test (t as Abs (s,T,body)) = + if test t then SOME (l:loc_,t) else get ((l@[D]):loc_) test body + | get l test (t as t1 $ t2) = + if test t then SOME (l,t) + else case get (l@[L]) test t1 of + NONE => get (l@[R]) test t2 + | SOME (l',t') => SOME (l',t'); +(*18.6.00 +> val sss = ((term_of o the o (parse thy)) + "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\ + \ (let e_ = Try (Rewrite square_equation_left True eq_) \ + \ in [e_])"); + ______ compares head_of !! +> get [] (eq_str "Let") sss; [R] +> get [] (eq_str "Script.Try") sss; [R,L,R] +> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R] +> get [] (eq_str "True") sss; [R,L,R,R,L,R] +> get [] (eq_str "e_") sss; [R,R] +*) + +fun test_negotiable t = + member op = (!negotiable) + ((strip_thy o (term_str (theory "Script")) o head_of) t); + +(*.get argument of first stactic in a script for init_form.*) +fun get_stac thy (h $ body) = +(* + *) + let + fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a = + (case get_t y e1 a of NONE => get_t y e2 a | la => la) + | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ = + (case get_t y e1 a of NONE => get_t y e2 a | la => la) + | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a + | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a + | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a + | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a + | get_t y (Const ("Script.Or",_) $e1 $ e2) a = + (case get_t y e1 a of NONE => get_t y e2 a | la => la) + | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ = + (case get_t y e1 a of NONE => get_t y e2 a | la => la) + | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a + | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a + | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a = + (case get_t y e1 a of NONE => get_t y e2 a | la => la) + (*| get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a = + (writeln("get_t: Let e1= "^(term2str e1)^", e2= "^(term2str e2)); + case get_t y e1 a of NONE => get_t y e2 a | la => la) + | get_t y (Abs (_,_,e)) a = get_t y e a*) + | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a = + get_t y e1 a (*don't go deeper without evaluation !*) + | get_t y (Const ("If",_) $ c $ e1 $ e2) a = NONE + (*(case get_t y e1 a of NONE => get_t y e2 a | la => la)*) + + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = SOME a + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = SOME a + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = SOME a + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = SOME a + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = SOME a + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = SOME a + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =SOME a + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =SOME a + | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = SOME a + | get_t y (Const ("Script.Calculate",_) $ _ ) a = SOME a + + | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = SOME a + | get_t y (Const ("Script.Substitute",_) $ _ ) a = SOME a + + | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = NONE + + | get_t y x _ = + ((*writeln ("### get_t yac: list-expr "^(term2str x));*) + NONE) +in get_t thy body e_term end; + +(*FIXME: get 1st stac by next_stac [] instead of ... ?? 29.7.02*) +(* val Script sc = scr; + *) +fun init_form thy (Script sc) env = + (case get_stac thy sc of + NONE => NONE (*raise error ("init_form: no 1st stac in "^ + (Syntax.string_of_term (thy2ctxt thy) sc))*) + | SOME stac => SOME (subst_atomic env stac)) + | init_form _ _ _ = raise error "init_form: no match"; + +(* use"ME/script.sml"; + use"script.sml"; + *) + + + +(*the 'iteration-argument' of a stac (args not eval)*) +fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v + | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v + | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v + | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v + | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v + | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts + | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term + | itr_arg _ (Const ("Script.Tac",_) $ _) = e_term + | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term + | itr_arg thy t = raise error + ("itr_arg not impl. for "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)); +(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_"; +> itr_arg "Script.thy" t; +val it = Free ("e_","RealDef.real") : term +> val t = (term_of o the o (parse thy))"xxx"; +> itr_arg "Script.thy" t; +*** itr_arg not impl. for xxx +uncaught exception ERROR + raised at: library.ML:1114.35-1114.40*) + + +(*.get the arguments of the script out of the scripts parsetree.*) +fun formal_args scr = (fst o split_last o snd o strip_comb) scr; +(* +> formal_args scr; + [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"), + Free ("eqs_","bool List.list")] : term list +*) + +(*.get the identifier of the script out of the scripts parsetree.*) +fun id_of_scr sc = (id_of o fst o strip_comb) sc; + + +(*WN020526: not clear, when a is available in ass_up for eva-_true*) +(*WN060906: in "fun handle_leaf" eg. uses "SOME M__"(from some PREVIOUS + curried Rewrite) for CURRENT value (which may be different from PREVIOUS); + thus "NONE" must be set at the end of currying (ill designed anyway)*) +fun upd_env_opt env (SOME a, v) = upd_env env (a,v) + | upd_env_opt env (NONE, v) = + (writeln("*** upd_env_opt: (NONE,"^(term2str v)^")");env); + + +type dsc = typ; (*<-> nam..unknow in Descript.thy*) +fun typ_str (Type (s,_)) = s + | typ_str (TFree(s,_)) = s + | typ_str (TVar ((s,i),_)) = s^(string_of_int i); + +(*get the _result_-type of a description*) +fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T; +(*> val t = (term_of o the o (parse thy)) "equality"; +> val T = type_of t; +val T = "bool => Tools.una" : typ +> val dsc = dsc_valT t; +val dsc = "una" : string + +> val t = (term_of o the o (parse thy)) "fixedValues"; +> val T = type_of t; +val T = "bool List.list => Tools.nam" : typ +> val dsc = dsc_valT t; +val dsc = "nam" : string*) + +(*.from penv in itm_ make args for script depending on type of description.*) +(*6.5.03 TODO: push penv into script -- and drop mk_arg here || drop penv + 9.5.03 penv postponed: penv = env for script at the moment, (*mk_arg*)*) +fun mk_arg thy d [] = raise error ("mk_arg: no data for "^ + (Syntax.string_of_term (thy2ctxt thy) d)) + | mk_arg thy d [t] = + (case dsc_valT d of + "una" => [t] + | "nam" => + [case t of + r as (Const ("op =",_) $ _ $ _) => r + | _ => raise error + ("mk_arg: dsc-typ 'nam' applied to non-equality "^ + (Syntax.string_of_term (thy2ctxt thy) t))] + | s => raise error ("mk_arg: not impl. for "^s)) + + | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts); +(* + val d = d_in itm_; + val [t] = ts_in itm_; +mk_arg thy +*) + + + + +(*.create the actual parameters (args) of script: their order + is given by the order in met.pat .*) +(*WN.5.5.03: ?: does this allow for different descriptions ??? + ?: why not taken from formal args of script ??? +!: FIXXXME penv: push it here in itms2args into script-evaluation*) +(* val (thy, mI, itms) = (thy, metID, itms); + *) +fun itms2args thy mI (itms:itm list) = + let val mvat = max_vt itms + fun okv mvat (_,vats,b,_,_) = member op = vats mvat andalso b + val itms = filter (okv mvat) itms + fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_) + fun itm2arg itms (_,(d,_)) = + case find_first (test_dsc d) itms of + NONE => + raise error ("itms2args: '"^term2str d^"' not in itms") + (*| SOME (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_); + penv postponed; presently penv holds already env for script*) + | SOME (_,_,_,_,itm_) => penvval_in itm_ + fun sel_given_find (s,_) = (s = "#Given") orelse (s = "#Find") + val pats = (#ppc o get_met) mI + in (flat o (map (itm2arg itms))) pats end; +(* +> val sc = ... Solve_root_equation ... +> val mI = ("Script.thy","sqrt-equ-test"); +> val PblObj{meth={ppc=itms,...},...} = get_obj I pt []; +> val ts = itms2args thy mI itms; +> map (Syntax.string_of_term (thy2ctxt thy)) ts; +["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list +*) + + +(*["bool_ (1+x=2)","real_ x"] --match_ags--> oris + --oris2fmz_vals--> ["equality (1+x=2)","boundVariable x","solutions L"]*) +fun oris2fmz_vals oris = + let fun ori2fmz_vals ((_,_,_,dsc,ts):ori) = + ((term2str o comp_dts') (dsc, ts), last_elem ts) + handle _ => raise error ("ori2fmz_env called with "^terms2str ts) + in (split_list o (map ori2fmz_vals)) oris end; + +(*detour necessary, because generate1 delivers a string-result*) +fun mout2term thy (Form' (FormKF (_,_,_,_,res))) = + (term_of o the o (parse (assoc_thy thy))) res + | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl + at time of detection in script*) + +(*.convert a script-tac 'stac' to a tactic 'tac'; if stac is an initac, + then convert to a 'tac_' (as required in appy). + arg pt:ptree for pushing the thy specified in rootpbl into subpbls.*) +fun stac2tac_ pt thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) = +(* val (pt, thy, (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f)) = + (pt, (assoc_thy th), stac); + *) + let val tid = (de_esc_underscore o strip_thy) thmID + in (Rewrite (tid, (string_of_thmI o + (assoc_thm' thy)) (tid,"")), Empty_Tac_) end +(* val (thy, + mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f)) + = (assoc_thy th,stac); + stac2tac_ pt thy mm; + + assoc_thm' (assoc_thy "Isac.thy") (tid,""); + assoc_thm' Isac.thy (tid,""); + *) + | stac2tac_ pt thy (Const ("Script.Rewrite'_Inst",_) $ + sub $ Free (thmID,_) $ _ $ f) = + let val subML = ((map isapair2pair) o isalist2list) sub + val subStr = subst2subs subML + val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*) + in (Rewrite_Inst + (subStr, (tid, (string_of_thmI o + (assoc_thm' thy)) (tid,""))), Empty_Tac_) end + + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)= + (Rewrite_Set ((de_esc_underscore o strip_thy) rls), Empty_Tac_) + + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set'_Inst",_) $ + sub $ Free (rls,_) $ _ $ f) = + let val subML = ((map isapair2pair) o isalist2list) sub; + val subStr = subst2subs subML; + in (Rewrite_Set_Inst (subStr,rls), Empty_Tac_) end + + | stac2tac_ pt thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) = + (Calculate op_, Empty_Tac_) + + | stac2tac_ pt thy (Const ("Script.Take",_) $ t) = + (Take (term2str t), Empty_Tac_) + + | stac2tac_ pt thy (Const ("Script.Substitute",_) $ isasub $ arg) = + (Substitute ((subte2sube o isalist2list) isasub), Empty_Tac_) +(* val t = str2term"Substitute [x = L, M_b L = 0] (M_b x = q_0 * x + c)"; + val Const ("Script.Substitute", _) $ isasub $ arg = t; + *) + +(*12.1.01.*) + | stac2tac_ pt thy (Const("Script.Check'_elementwise",_) $ _ $ + (set as Const ("Collect",_) $ Abs (_,_,pred))) = + (Check_elementwise (Syntax.string_of_term (thy2ctxt thy) pred), + (*set*)Empty_Tac_) + + | stac2tac_ pt thy (Const("Script.Or'_to'_List",_) $ _ ) = + (Or_to_List, Empty_Tac_) + +(*12.1.01.for subproblem_equation_dummy in root-equation *) + | stac2tac_ pt thy (Const ("Script.Tac",_) $ Free (str,_)) = + (Tac ((de_esc_underscore o strip_thy) str), Empty_Tac_) + (*L_ will come from pt in appl_in*) + + (*3.12.03 copied from assod SubProblem*) +(* val Const ("Script.SubProblem",_) $ + (Const ("Pair",_) $ + Free (dI',_) $ + (Const ("Pair",_) $ pI' $ mI')) $ ags' = + str2term + "SubProblem (EqSystem_, [linear, system], [no_met])\ + \ [bool_list_ [c_2 = 0, L * c + c_2 = q_0 * L ^^^ 2 / 2],\ + \ real_list_ [c, c_2]]"; +*) + | stac2tac_ pt thy (stac as Const ("Script.SubProblem",_) $ + (Const ("Pair",_) $ + Free (dI',_) $ + (Const ("Pair",_) $ pI' $ mI')) $ ags') = +(*compare "| assod _ (Subproblem'"*) + let val dI = ((implode o drop_last(*.._*) o explode) dI')^".thy"; + val thy = maxthy (assoc_thy dI) (rootthy pt); + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI'; + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI'; + val ags = isalist2list ags'; + val (pI, pors, mI) = + if mI = ["no_met"] + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags) + handle _ =>(match_ags_msg pI stac ags(*raise exn*);[]) + val pI' = refine_ori' pors pI; + in (pI', pors (*refinement over models with diff.prec only*), + (hd o #met o get_pbt) pI') end + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags) + handle _ => (match_ags_msg pI stac ags(*raise exn*); []), + mI); + val (fmz_, vals) = oris2fmz_vals pors; + val {cas,ppc,thy,...} = get_pbt pI + val dI = theory2theory' thy (*.take dI from _refined_ pbl.*) + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt)); + val hdl = case cas of + NONE => pblterm dI pI + | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t + val f = subpbl (strip_thy dI) pI + in (Subproblem (dI, pI), + Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f)) + end + + | stac2tac_ pt thy t = raise error + ("stac2tac_ TODO: no match for "^ + (Syntax.string_of_term (thy2ctxt thy) t)); +(* +> val t = (term_of o the o (parse thy)) + "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)"; +> stac2tac_ pt t; +val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : tac + +> val t = (term_of o the o (parse SqRoot.thy)) +"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\ + \ [bool_ e_, real_ v_])::bool list"; +> stac2tac_ pt SqRoot.thy t; +val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #))) +*) + +fun stac2tac pt thy t = (fst o stac2tac_ pt thy) t; + + + + +(*test a term for being a _list_ (set ?) of constants; could be more rigorous*) +fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true + | list_of_consts (Const ("List.list.Nil",_)) = true + | list_of_consts _ = false; +(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]"; +> list_of_consts ttt; +val it = true : bool +> val ttt = (term_of o the o (parse thy)) "[]"; +> list_of_consts ttt; +val it = true : bool*) + + + + + +(* 15.1.01: evaluation of preds only works occasionally, + but luckily for the 2 examples of root-equ: +> val s = ((term_of o the o (parse thy)) "x", + (term_of o the o (parse thy)) "-#5//#12"); +> val asm = (term_of o the o (parse thy)) + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)"; +> val pred = subst_atomic [s] asm; +> rewrite_set_ thy false ((cterm_of thy) pred); +val it = NONE : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!! +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred); +val it = false : bool + +> val s = ((term_of o the o (parse thy)) "x", + (term_of o the o (parse thy)) "#4"); +> val asm = (term_of o the o (parse thy)) + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)"; +> val pred = subst_atomic [s] asm; +> rewrite_set_ thy false ((cterm_of thy) pred); +val it = SOME ("True & True",[]) : (cterm * cterm list) option +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred); +val it = true : bool`*) + +(*for check_elementwise: take apart the set, ev. instantiate assumptions +fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) = + let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set; + val bdv = Free (bdv,T); + val pred = if pred <> Const ("Script.Assumptions",bool) + then pred + else (mk_and o (map fst)) (get_assumptions_ pt (p,Res)) + in (bdv, pred) end + | rep_set thy _ _ set = + raise error ("check_elementwise: no set "^ (*from script*) + (Syntax.string_of_term (thy2ctxt thy) set)); +(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}"; +> val p = []; +> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]), + ("#0 <= #9 + #4 * x",[22]), + ("#0 <= x ^^^ #2 + #5 * x",[33]), + ("#0 <= #2 + x",[44])]; +> val (bdv,pred) = rep_set thy pt p set; +val bdv = Free ("x","RealDef.real") : term +> writeln (Syntax.string_of_term (thy2ctxt thy) pred); +((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & + #0 <= x ^^^ #2 + #5 * x) & +#0 <= #2 + x +*) +--------------------------------------------11.6.03--was unused*) + + + + +datatype ass = + Ass of tac_ * (*SubProblem gets args instantiated in assod*) + term (*for itr_arg,result in ets*) +| AssWeak of tac_ * + term (*for itr_arg,result in ets*) +| NotAss; + +(*.assod: tac_ associated with stac w.r.t. d +args + pt:ptree for pushing the thy specified in rootpbl into subpbls +returns + Ass : associated: e.g. thmID in stac = thmID in m + +++ arg in stac = arg in m + AssWeak: weakly ass.:e.g. thmID in stac = thmID in m, //arg// + NotAss : e.g. thmID in stac/=/thmID in m (not =) +8.01: + tac_ SubProblem with args completed from script +.*) +fun assod pt d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) stac = + (case stac of + (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $b$f_)=> + if thmID = thmID_ then + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f')) + else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f')) + else ((*writeln"3### assod ..NotAss";*)NotAss) + | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $_$f_)=> + if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + | _ => NotAss) + + | assod pt d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm))) stac = + (case stac of + (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) => + ((*writeln("3### assod: stac = "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)); + writeln("3### assod: f(m)= "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) f));*) + if thmID = thmID_ then + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f')) + else ((*writeln"### assod ..AssWeak"; + writeln("### assod: f(m) = "^ + (Sign.string_of_term (sign_of(assoc_thy thy)) f)); + writeln("### assod: f(stac)= "^ + (Sign.string_of_term(sign_of(assoc_thy thy))f_))*) + AssWeak (m,f')) + else ((*writeln"3### assod ..NotAss";*)NotAss)) + | (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) => + if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + | _ => NotAss) + +(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0"; +> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0"; +> val m = Rewrite'("Script.thy","tless_true","eval_rls",false, + ("rroot_square_inv",""),f,(f',[])); +> val stac = (term_of o the o (parse thy)) + "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)"; +> assod e_rls m stac; +val it = + (SOME (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"), + Const ("empty","RealDef.real")) : tac_ option * term * term*) + + | assod pt d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm))) + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)= + if id_rls rls = rls_ then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + + | assod pt d (m as Detail_Set_Inst' (thy',put,sub,rls,f,(f',asm))) + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)= + if id_rls rls = rls_ then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + + | assod pt d (m as Rewrite_Set' (thy,put,rls,f,(f',asm))) + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) = + if id_rls rls = rls_ then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + + | assod pt d (m as Detail_Set' (thy,put,rls,f,(f',asm))) + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) = + if id_rls rls = rls_ then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + + | assod pt d (m as Calculate' (thy',op_,f,(f',thm'))) stac = + (case stac of + (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) => + if op_ = op__ then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free(rls_,_) $_$f_)=> + if contains_rule (Calc (snd (assoc1 (!calclist', op_)))) + (assoc_rls rls_) then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + | (Const ("Script.Rewrite'_Set",_) $ Free (rls_, _) $ _ $ f_) => + if contains_rule (Calc (snd (assoc1 (!calclist', op_)))) + (assoc_rls rls_) then + if f = f_ then Ass (m,f') else AssWeak (m,f') + else NotAss + | _ => NotAss) + + | assod pt _ (m as Check_elementwise' (consts,_,(consts_chkd,_))) + (Const ("Script.Check'_elementwise",_) $ consts' $ _) = + ((*writeln("### assod Check'_elementwise: consts= "^(term2str consts)^ + ", consts'= "^(term2str consts')); + atomty consts; atomty consts';*) + if consts = consts' then ((*writeln"### assod Check'_elementwise: Ass";*) + Ass (m, consts_chkd)) + else ((*writeln"### assod Check'_elementwise: NotAss";*) NotAss)) + + | assod pt _ (m as Or_to_List' (ors, list)) + (Const ("Script.Or'_to'_List",_) $ _) = + Ass (m, list) + + | assod pt _ (m as Take' term) + (Const ("Script.Take",_) $ _) = + Ass (m, term) + + | assod pt _ (m as Substitute' (_, _, res)) + (Const ("Script.Substitute",_) $ _ $ _) = + Ass (m, res) +(* val t = str2term "Substitute [(x, 3)] (x^^^2 + x + 1)"; + val (Const ("Script.Substitute",_) $ _ $ _) = t; + *) + + | assod pt _ (m as Tac_ (thy,f,id,f')) + (Const ("Script.Tac",_) $ Free (id',_)) = + if id = id' then Ass (m, ((term_of o the o (parse thy)) f')) + else NotAss + + +(* val t = str2term + "SubProblem (DiffApp_,[make,function],[no_met]) \ + \[real_ m_, real_ v_, bool_list_ rs_]"; + + val (Subproblem' ((domID,pblID,metID),_,_,_,f)) = m; + val (Const ("Script.SubProblem",_) $ + (Const ("Pair",_) $ + Free (dI',_) $ + (Const ("Pair",_) $ pI' $ mI')) $ ags') = stac; + *) + | assod pt _ (Subproblem' ((domID,pblID,metID),_,_,_,f)) + (stac as Const ("Script.SubProblem",_) $ + (Const ("Pair",_) $ + Free (dI',_) $ + (Const ("Pair",_) $ pI' $ mI')) $ ags') = +(*compare "| stac2tac_ thy (Const ("Script.SubProblem",_)"*) + let val dI = ((implode o drop_last o explode) dI')^".thy"; + val thy = maxthy (assoc_thy dI) (rootthy pt); + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI'; + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI'; + val ags = isalist2list ags'; + val (pI, pors, mI) = + if mI = ["no_met"] + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags) + handle _=>(match_ags_msg pI stac ags(*raise exn*);[]); + val pI' = refine_ori' pors pI; + in (pI', pors (*refinement over models with diff.prec only*), + (hd o #met o get_pbt) pI') end + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags) + handle _ => (match_ags_msg pI stac ags(*raise exn*);[]), + mI); + val (fmz_, vals) = oris2fmz_vals pors; + val {cas, ppc,...} = get_pbt pI + val {cas, ppc, thy,...} = get_pbt pI + val dI = theory2theory' thy (*take dI from _refined_ pbl*) + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt)) + val hdl = case cas of + NONE => pblterm dI pI + | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t + val f = subpbl (strip_thy dI) pI + in if domID = dI andalso pblID = pI + then Ass (Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f), f) + else NotAss + end + + | assod pt d m t = + (if (!trace_script) + then writeln("@@@ the 'tac_' proposed to apply does NOT match the leaf found in the script:\n"^ + "@@@ tac_ = "^(tac_2str m)) + else (); + NotAss); + + + +fun tac_2tac (Refine_Tacitly' (pI,_,_,_,_)) = Refine_Tacitly pI + | tac_2tac (Model_Problem' (pI,_,_)) = Model_Problem + | tac_2tac (Add_Given' (t,_)) = Add_Given t + | tac_2tac (Add_Find' (t,_)) = Add_Find t + | tac_2tac (Add_Relation' (t,_)) = Add_Relation t + + | tac_2tac (Specify_Theory' dI) = Specify_Theory dI + | tac_2tac (Specify_Problem' (dI,_)) = Specify_Problem dI + | tac_2tac (Specify_Method' (dI,_,_)) = Specify_Method dI + + | tac_2tac (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) = + Rewrite (thmID,thm) + + | tac_2tac (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))= + Rewrite_Inst (subst2subs sub,(thmID,thm)) + + | tac_2tac (Rewrite_Set' (thy,put,rls,f,(f',asm))) = + Rewrite_Set (id_rls rls) + + | tac_2tac (Detail_Set' (thy,put,rls,f,(f',asm))) = + Detail_Set (id_rls rls) + + | tac_2tac (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) = + Rewrite_Set_Inst (subst2subs sub,id_rls rls) + + | tac_2tac (Detail_Set_Inst' (thy,put,sub,rls,f,(f',asm))) = + Detail_Set_Inst (subst2subs sub,id_rls rls) + + | tac_2tac (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_) + + | tac_2tac (Check_elementwise' (consts,pred,consts')) = + Check_elementwise pred + + | tac_2tac (Or_to_List' _) = Or_to_List + | tac_2tac (Take' term) = Take (term2str term) + | tac_2tac (Substitute' (subte, t, res)) = Substitute (subte2sube subte) + + | tac_2tac (Tac_ (_,f,id,f')) = Tac id + + | tac_2tac (Subproblem' ((domID, pblID, _), _, _,_,_)) = + Subproblem (domID, pblID) + | tac_2tac (Check_Postcond' (pblID, _)) = + Check_Postcond pblID + | tac_2tac Empty_Tac_ = Empty_Tac + + | tac_2tac m = + raise error ("tac_2tac: not impl. for "^(tac_2str m)); + + + + +(** decompose tac_ to a rule and to (lhs,rhs) + unly needed ~~~ **) + +val idT = Type ("Script.ID",[]); +(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID"; +type_of tt = idT; +val it = true : bool +*) + +fun make_rule thy t = + let val ct = cterm_of thy (Trueprop $ t) + in Thm (Syntax.string_of_term (thy2ctxt thy) (term_of ct), make_thm ct) end; + +(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m; + *) +(*decompose tac_ to a rule and to (lhs,rhs) for ets FIXME.12.03: obsolete! + NOTE.12.03: also used for msg 'not locatable' ?!: 'Subproblem' missing !!! +WN0508 only use in tac_2res, which uses only last return-value*) +fun rep_tac_ (Rewrite_Inst' + (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) = + let val fT = type_of f; + val b = if put then HOLogic.true_const else HOLogic.false_const; + val sT = (type_of o fst o hd) subs; + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) + (map HOLogic.mk_prod subs); + val sT' = type_of subs'; + val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT) + $ subs' $ Free (thmID,idT) $ b $ f; + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end +(*Fehlersuche 25.4.01 +(a)----- als String zusammensetzen: +ML> Syntax.string_of_term (thy2ctxt thy)f; +val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string +ML> Syntax.string_of_term (thy2ctxt thy)f'; +val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string +ML> subs; +val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst +> val tt = (term_of o the o (parse thy)) + "(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))"; +> atomty tt; +ML> writeln(Syntax.string_of_term (thy2ctxt thy)tt); +(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) + +(b)----- laut rep_tac_: +> val ttt=HOLogic.mk_eq (lhs,f'); +> atomty ttt; + + +(*Fehlersuche 1-2Monate vor 4.01:*) +> val tt = (term_of o the o (parse thy)) + "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)"; +> atomty tt; + +> val f = (term_of o the o (parse thy)) "x=#1+#2"; +> val f' = (term_of o the o (parse thy)) "x=#3"; +> val subs = [((term_of o the o (parse thy)) "bdv", + (term_of o the o (parse thy)) "x")]; +> val sT = (type_of o fst o hd) subs; +> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) + (map HOLogic.mk_prod subs); +> val sT' = type_of subs'; +> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT) + $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f; +> lhs = tt; +val it = true : bool +> rep_tac_ (Rewrite_Inst' + ("Script.thy","tless_true","eval_rls",false,subs, + ("square_equation_left",""),f,(f',[]))); +*) + | rep_tac_ (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))= + let + val fT = type_of f; + val b = if put then HOLogic.true_const else HOLogic.false_const; + val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT) + $ Free (thmID,idT) $ b $ f; + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end +(* +> val tt = (term_of o the o (parse thy)) (*____ ____..test*) + "Rewrite square_equation_left True (x=#1+#2) = (x=#3)"; + +> val f = (term_of o the o (parse thy)) "x=#1+#2"; +> val f' = (term_of o the o (parse thy)) "x=#3"; +> val Thm (id,thm) = + rep_tac_ (Rewrite' + ("Script.thy","tless_true","eval_rls",false, + ("square_equation_left",""),f,(f',[]))); +> val SOME ct = parse thy + "Rewrite square_equation_left True (x=#1+#2)"; +> rewrite_ Script.thy tless_true eval_rls true thm ct; +val it = SOME ("x = #3",[]) : (cterm * cterm list) option +*) + | rep_tac_ (Rewrite_Set_Inst' + (thy',put,subs,rls,f,(f',asm))) = + (e_rule, (e_term, f')) +(*WN050824: type error ... + let val fT = type_of f; + val sT = (type_of o fst o hd) subs; + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) + (map HOLogic.mk_prod subs); + val sT' = type_of subs'; + val b = if put then HOLogic.true_const else HOLogic.false_const + val lhs = Const ("Script.Rewrite'_Set'_Inst", + [sT',idT,fT,fT] ---> fT) + $ subs' $ Free (id_rls rls,idT) $ b $ f; + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end*) +(* ... vals from Rewrite_Inst' ... +> rep_tac_ (Rewrite_Set_Inst' + ("Script.thy",false,subs, + "isolate_bdv",f,(f',[]))); +*) +(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m; +*) + | rep_tac_ (Rewrite_Set' (thy',put,rls,f,(f',asm)))= + let val fT = type_of f; + val b = if put then HOLogic.true_const else HOLogic.false_const; + val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT) + $ Free (id_rls rls,idT) $ b $ f; + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end +(* 13.3.01: +val thy = assoc_thy thy'; +val t = HOLogic.mk_eq (lhs,f'); +make_rule thy t; +-------------------------------------------------- +val lll = (term_of o the o (parse thy)) + "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)"; + +-------------------------------------------------- +> val f = (term_of o the o (parse thy)) "x=#1+#2"; +> val f' = (term_of o the o (parse thy)) "x=#3"; +> val Thm (id,thm) = + rep_tac_ (Rewrite_Set' + ("Script.thy",false,"SqRoot_simplify",f,(f',[]))); +val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string +val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm +*) + | rep_tac_ (Calculate' (thy',op_,f,(f',thm')))= + let val fT = type_of f; + val lhs = Const ("Script.Calculate",[idT,fT] ---> fT) + $ Free (op_,idT) $ f + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end +(* +> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)"; + ... test-root-equ.sml: calculate ... +> val Appl m'=applicable_in p pt (Calculate "PLUS"); +> val (lhs,_)=tac_2etac m'; +> lhs'=lhs; +val it = true : bool*) + | rep_tac_ (Check_elementwise' (t,str,(t',asm))) = (Erule, (e_term, t')) + | rep_tac_ (Subproblem' (_,_,_,_,t')) = (Erule, (e_term, t')) + | rep_tac_ (Take' (t')) = (Erule, (e_term, t')) + | rep_tac_ (Substitute' (subst,t,t')) = (Erule, (t, t')) + | rep_tac_ (Or_to_List' (t, t')) = (Erule, (t, t')) + | rep_tac_ m = raise error ("rep_tac_: not impl.for "^ + (tac_2str m)); + +(*"N.3.6.03------ +fun tac_2rule m = (fst o rep_tac_) m; +fun tac_2etac m = (snd o rep_tac_) m; +fun tac_2tac m = (fst o snd o rep_tac_) m;*) +fun tac_2res m = (snd o snd o rep_tac_) m;(*ONLYuse of rep_tac_ + FIXXXXME: simplify rep_tac_*) + + +(*.handle a leaf; + a leaf is either a tactic or an 'exp' in 'let v = expr' + where 'exp' does not contain a tactic. + handling a leaf comprises + (1) 'subst_stacexpr' substitute env and complete curried tactic + (2) rewrite the leaf by 'srls' +WN060906 quick and dirty fix: return a' too (for updating E later) +.*) +fun handle_leaf call thy srls E a v t = + (*WN050916 'upd_env_opt' is a blind copy from previous version*) + case subst_stacexpr E a v t of + (a', STac stac) => (*script-tactic*) + let val stac' = eval_listexpr_ (assoc_thy thy) srls + (subst_atomic (upd_env_opt E (a,v)) stac) + in (if (!trace_script) + then writeln ("@@@ "^call^" leaf '"^term2str t^"' ---> STac '"^ + term2str stac'^"'") + else (); + (a', STac stac')) + end + | (a', Expr lexpr) => (*leaf-expression*) + let val lexpr' = eval_listexpr_ (assoc_thy thy) srls + (subst_atomic (upd_env_opt E (a,v)) lexpr) + in (if (!trace_script) + then writeln("@@@ "^call^" leaf '"^term2str t^"' ---> Expr '"^ + term2str lexpr'^"'") + else (); + (a', Expr lexpr')) + end; + + + +(** locate an applicable stactic in a script **) + +datatype assoc = (*ExprVal in the sense of denotational semantics*) + Assoc of (*the stac is associated, strongly or weakly*) + scrstate * (*the current; returned for next_tac etc. outside ass* *) + (step list) (*list of steps done until associated stac found; + initiated with the data for doing the 1st step, + thus the head holds these data further on, + while the tail holds steps finished (incl.scrstate in ptree)*) +| NasApp of (*stac not associated, but applicable, ptree-node generated*) + scrstate * (step list) +| NasNap of (*stac not associated, not applicable, nothing generated; + for distinction in Or, for leaving iterations, leaving Seq, + evaluate scriptexpressions*) + term * env; +fun assoc2str (Assoc _) = "Assoc" + | assoc2str (NasNap _) = "NasNap" + | assoc2str (NasApp _) = "NasApp"; + + +datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*) + Aundef (*undefined: set only by (topmost) Or*) +| AssOnly (*do not execute appl stacs - there could be an associated + in parallel Or-branch*) +| AssGen; (*no Ass(Weak) found within Or, thus + search for _applicable_ stacs, execute and generate pt*) +(*this constructions doesnt allow arbitrary nesting of Or !!!*) + + +(*assy, ass_up, astep_up scanning for locate_gen at stactic in a script. + search is clearly separated into (1)-(2): + (1) assy is recursive descent; + (2) ass_up resumes interpretation at a location somewhere in the script; + astep_up does only get to the parentnode of the scriptexpr. + consequence: + * call of (2) means _always_ that in this branch below + there was an appl.stac (Repeat, Or e1, ...) +*) +fun assy ya (is as (E,l,a,v,S,b),ss) + (Const ("Let",_) $ e $ (Abs (id,T,body))) = +(* val (ya, (is as (E,l,a,v,S,b),ss),Const ("Let",_) $ e $ (Abs (id,T,body))) = + (*1*)(((ts,d),Aundef), ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]), body); + *) + ((*writeln("### assy Let$e$Abs: is="); + writeln(istate2str (ScrState is));*) + case assy ya ((E , l@[L,R], a,v,S,b),ss) e of + NasApp ((E',l,a,v,S,bb),ss) => + let val id' = mk_Free (id, T); + val E' = upd_env E' (id', v); + (*val _=writeln("### assy Let -> NasApp");*) + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end + | NasNap (v,E) => + let val id' = mk_Free (id, T); + val E' = upd_env E (id', v); + (*val _=writeln("### assy Let -> NasNap");*) + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end + | ay => ay) + + | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss) + (Const ("Script.While",_) $ c $ e $ a) = + ((*writeln("### assy While $ c $ e $ a, upd_env= "^ + (subst2str (upd_env E (a,v))));*) + if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c) + then assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e + else NasNap (v, E)) + + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss) + (Const ("Script.While",_) $ c $ e) = + ((*writeln("### assy While, l= "^(loc_2str l));*) + if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c) + then assy ya ((E, l@[R], a,v,S,b),ss) e + else NasNap (v, E)) + + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss) + (Const ("If",_) $ c $ e1 $ e2) = + (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c) + then assy ya ((E, l@[L,R], a,v,S,b),ss) e1 + else assy ya ((E, l@[ R], a,v,S,b),ss) e2) + + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) = + ((*writeln("### assy Try $ e $ a, l= "^(loc_2str l));*) + case assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e of + ay => ay) + + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) = + ((*writeln("### assy Try $ e, l= "^(loc_2str l));*) + case assy ya ((E, l@[R], a,v,S,b),ss) e of + ay => ay) +(* val (ya, ((E,l,_,v,S,b),ss), (Const ("Script.Seq",_) $e1 $ e2 $ a)) = + (*2*)(ya, ((E , l@[L,R], a,v,S,b),ss), e); + *) + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) = + ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*) + case assy ya ((E, l@[L,L,R], SOME a,v,S,b),ss) e1 of + NasNap (v, E) => assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2 + | NasApp ((E,_,_,v,_,_),ss) => + assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2 + | ay => ay) + + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) = + (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of + NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2 + | NasApp ((E,_,_,v,_,_),ss) => + assy ya ((E, l@[R], a,v,S,b),ss) e2 + | ay => ay) + + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) = + assy ya ((E,(l@[L,R]),SOME a,v,S,b),ss) e + + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) = + assy ya ((E,(l@[R]),a,v,S,b),ss) e + +(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*) + | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) = + (case assy (y, AssOnly) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of + NasNap (v, E) => + (case assy (y, AssOnly) ((E,(l@[L,R]),SOME a,v,S,b),ss) e2 of + NasNap (v, E) => + (case assy (y, AssGen) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of + NasNap (v, E) => + assy (y, AssGen) ((E, (l@[L,R]), SOME a,v,S,b),ss) e2 + | ay => ay) + | ay =>(ay)) + | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///") + | ay => (ay)) + + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) = + (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of + NasNap (v, E) => + assy ya ((E,(l@[R]),a,v,S,b),ss) e2 + | ay => (ay)) +(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])]; + val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False"; + + val (ap,(p,p_),c,ss) = (Aundef,p,[],[]); + assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,EmptyMout,pt,(p,p_),c)::ss) t; +val ((((thy',sr),d),ap), (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss), t) = + (); + *) + + | assy (((thy',sr),d),ap) (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t = + ((*writeln("### assy, m = "^tac_2str m); + writeln("### assy, (p,p_) = "^pos'2str (p,p_)); + writeln("### assy, is= "); + writeln(istate2str (ScrState is));*) + case handle_leaf "locate" thy' sr E a v t of + (a', Expr s) => + ((*writeln("### assy: listexpr t= "^(term2str t)); + writeln("### assy, E= "^(env2str E)); + writeln("### assy, eval(..)= "^(term2str + (eval_listexpr_ (assoc_thy thy') sr + (subst_atomic (upd_env_opt E (a',v)) t))));*) + NasNap (eval_listexpr_ (assoc_thy thy') sr + (subst_atomic (upd_env_opt E (a',v)) t), E)) + (* val (_,STac stac) = subst_stacexpr E a v t; + *) + | (a', STac stac) => + let (*val _=writeln("### assy, stac = "^term2str stac);*) + val p' = case p_ of Frm => p | Res => lev_on p + | _ => raise error ("assy: call by "^ + (pos'2str (p,p_))); + in case assod pt d m stac of + Ass (m,v') => + let (*val _=writeln("### assy: Ass ("^tac_2str m^", "^ + term2str v'^")");*) + val (p'',c',f',pt') = generate1 (assoc_thy thy') m + (ScrState (E,l,a',v',S,true)) (p',p_) pt; + in Assoc ((E,l,a',v',S,true), (m,f',pt',p'',c @ c')::ss) end + | AssWeak (m,v') => + let (*val _=writeln("### assy: Ass Weak("^tac_2str m^", "^ + term2str v'^")");*) + val (p'',c',f',pt') = generate1 (assoc_thy thy') m + (ScrState (E,l,a',v',S,false)) (p',p_) pt; + in Assoc ((E,l,a',v',S,false), (m,f',pt',p'',c @ c')::ss) end + | NotAss => + ((*writeln("### assy, NotAss");*) + case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*) + AssOnly => (NasNap (v, E)) + | gen => (case applicable_in (p,p_) pt + (stac2tac pt (assoc_thy thy') stac) of + Appl m' => + let val is = (E,l,a',tac_2res m',S,false(*FIXXXME*)) + val (p'',c',f',pt') = + generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt; + in NasApp (is,(m,f',pt',p'',c @ c')::ss) end + | Notappl _ => + (NasNap (v, E)) + ) + ) + end); +(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e; + *) + + +(* val (ys as (y,s,Script sc,d),(is as (E,l,a,v,S,b),ss),Const ("Let",_) $ _) = + (ys, ((E,up,a,v,S,b),ss), go up sc); + *) +fun ass_up (ys as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss) + (Const ("Let",_) $ _) = + let (*val _= writeln("### ass_up1 Let$e: is=") + val _= writeln(istate2str (ScrState is))*) + val l = drop_last l; (*comes from e, goes to Abs*) + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc; + val i = mk_Free (i, T); + val E = upd_env E (i, v); + (*val _=writeln("### ass_up2 Let$e: E="^(subst2str E));*) + in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of + Assoc iss => Assoc iss + | NasApp iss => astep_up ys iss + | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end + + | ass_up ys (iss as (is,_)) (Abs (_,_,_)) = + ((*writeln("### ass_up Abs: is="); + writeln(istate2str (ScrState is));*) + astep_up ys iss) (*TODO 5.9.00: env ?*) + + | ass_up ys (iss as (is,_)) (Const ("Let",_) $ e $ (Abs (i,T,b)))= + ((*writeln("### ass_up Let $ e $ Abs: is="); + writeln(istate2str (ScrState is));*) + astep_up ys iss) (*TODO 5.9.00: env ?*) + + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _ $ _)) = + (ys, ((E,up,a,v,S,b),ss), (go up sc)); + *) + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) = + astep_up ysa iss (*all has been done in (*2*) below*) + + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) = + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _)) = + (ys, ((E,up,a,v,S,b),ss), (go up sc)); + *) + astep_up ysa iss (*2*: comes from e2*) + + | ass_up (ysa as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss) + (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*) + (* val ((ysa as (y,s,Script sc,d)), (is as (E,l,a,v,S,b),ss), + (Const ("Script.Seq",_) $ _ )) = + (ys, ((E,up,a,v,S,b),ss), (go up sc)); + *) + let val up = drop_last l; + val Const ("Script.Seq",_) $ _ $ e2 = go up sc + (*val _= writeln("### ass_up Seq$e: is=") + val _= writeln(istate2str (ScrState is))*) + in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of + NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss) + | NasApp iss => astep_up ysa iss + | ay => ay end + + (* val (ysa, iss, (Const ("Script.Try",_) $ e $ _)) = + (ys, ((E,up,a,v,S,b),ss), (go up sc)); + *) + | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) = + astep_up ysa iss + + (* val (ysa, iss, (Const ("Script.Try",_) $ e)) = + (ys, ((E,up,a,v,S,b),ss), (go up sc)); + *) + | ass_up ysa iss (Const ("Script.Try",_) $ e) = + ((*writeln("### ass_up Try $ e");*) + astep_up ysa iss) + + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss) + (*(Const ("Script.While",_) $ c $ e $ a) = WN050930 blind fix*) + (t as Const ("Script.While",_) $ c $ e $ a) = + ((*writeln("### ass_up: While c= "^ + (term2str (subst_atomic (upd_env E (a,v)) c)));*) + if eval_true_ y s (subst_atomic (upd_env E (a,v)) c) + then (case assy (((y,s),d),Aundef) ((E, l@[L,R], SOME a,v,S,b),ss) e of + NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss) + | NasApp ((E',l,a,v,S,b),ss) => + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*) + | ay => ay) + else astep_up ys ((E,l, SOME a,v,S,b),ss) + ) + + | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss) + (*(Const ("Script.While",_) $ c $ e) = WN050930 blind fix*) + (t as Const ("Script.While",_) $ c $ e) = + if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c) + then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of + NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss) + | NasApp ((E',l,a,v,S,b),ss) => + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*) + | ay => ay) + else astep_up ys ((E,l, a,v,S,b),ss) + + | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss + + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss) + (t as Const ("Script.Repeat",_) $ e $ a) = + (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), SOME a,v,S,b),ss) e of + NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss) + | NasApp ((E',l,a,v,S,b),ss) => + ass_up ys ((E',l,a,v,S,b),ss) t + | ay => ay) + + | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss)) + (t as Const ("Script.Repeat",_) $ e) = + (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of + NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss) + | NasApp ((E',l,a,v',S,bb),ss) => + ass_up ys ((E',l,a,v',S,b),ss) t + | ay => ay) + + | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss + + | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss + + | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) = + astep_up y ((E, (drop_last l), a,v,S,b),ss) + + | ass_up y iss t = + raise error ("ass_up not impl for t= "^(term2str t)) +(* 9.6.03 + val (ys as (_,_,Script sc,_), ss) = + ((thy',srls,scr,d), [(m,EmptyMout,pt,p,[])]:step list); + astep_up ys ((E,l,a,v,S,b),ss); + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) = + (ysa, iss); + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) = + ((thy',srls,scr,d), ((E,l,a,v,S,b), [(m,EmptyMout,pt,p,[])])); + *) +and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) = + if 1 < length l + then + let val up = drop_last l; + (*val _= writeln("### astep_up: E= "^env2str E);*) + in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end + else (NasNap (v, E)) +; + + + + + +(* use"ME/script.sml"; + use"script.sml"; + term2str (go up sc); + + *) + +(*check if there are tacs for rewriting only*) +fun rew_only ([]:step list) = true + | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss + | rew_only _ = false; + + +datatype locate = + Steps of istate (*producing hd of step list (which was latest) + for next_tac, for reporting Safe|Unsafe to DG*) + * step (*(scrstate producing this step is in ptree !)*) + list (*locate_gen may produce intermediate steps*) +| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*) + + + +(* locate_gen tries to locate an input tac m in the script. + pursuing this goal the script is executed until an (m' equiv m) is found, + or the end of the script +args + m : input by the user, already checked by applicable_in, + (to be searched within Or; and _not_ an m doing the step on ptree !) + p,pt: (incl ets) at the time of input + scr : the script + d : canonical simplifier for locating Take, Substitute, Subproblems etc. + ets : ets at the time of input + l : the location (in scr) of the stac which generated the current formula +returns + Steps: pt,p (incl. ets) with m done + pos' list of proofobjs cut (from generate) + safe: implied from last proofobj + ets: + ///ToDo : ets contains a list of tacs to be done before m can be done + NOT IMPL. -- "error: do other step before" + NotLocatable: thus generate_hard +*) +(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...}, + RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is); + *) +fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p) + (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) = + (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of + [] => NotLocatable + | rts' => + Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts')) +(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is; + locate_gen (thy':theory') (m:tac_) ((pt,p):ptree * pos') + (scr,d) (E,l,a,v,S,bb); + 9.6.03 + val ts = (thy',srls); + val p = (p,p_); + val (scr as Script (h $ body)) = (sc); + val ScrState (E,l,a,v,S,b) = (is); + + val (ts as (thy',srls), m, (pt,p), + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = + ((thy',srls), m, (pt,(p,p_)), (sc,d), is); + locate_gen (thy',srls) m (pt,p) (Script(h $ body),d)(ScrState(E,l,a,v,S,b)); + + val (ts as (thy',srls), m, (pt,p), + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = + ((thy',srls), m', (pt,(lev_on p,Frm)), (sc,d), is'); + + val (ts as (thy',srls), m, (pt,p), + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = + ((thy',srls), m', (pt,(p, Res)), (sc,d), is'); + + val (ts as (thy',srls), m, (pt,p), + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = + ((thy',srls), m, (pt,(p,p_)), (sc,d), is); + *) + | locate_gen (ts as (thy',srls)) (m:tac_) ((pt,p):ptree * pos') + (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) = + let (*val _= writeln("### locate_gen-----------------: is="); + val _= writeln( istate2str (ScrState (E,l,a,v,S,b))); + val _= writeln("### locate_gen: l= "^loc_2str l^", p= "^pos'2str p)*) + val thy = assoc_thy thy'; + in case if l=[] orelse ((*init.in solve..Apply_Method...*) + (last_elem o fst) p = 0 andalso snd p = Res) + then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b), + [(m,EmptyMout,pt,p,[])]) body) +(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) = + (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])); + (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]) body); + *) + else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b), + [(m,EmptyMout,pt,p,[])]) ) of + Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) => +(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) = + (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b), + [(m,EmptyMout,pt,p,[])]) ); + *) + ((*writeln("### locate_gen Assoc: p'="^(pos'2str p'));*) + if bb then Steps (ScrState is, ss) + else if rew_only ss (*andalso 'not bb'= associated weakly*) + then let val (po,p_) = p + val po' = case p_ of Frm => po | Res => lev_on po + (*WN.12.03: noticed, that pos is also updated in assy !?! + instead take p' from Assoc ?????????????????????????????*) + val (p'',c'',f'',pt'') = + generate1 thy m (ScrState is) (po',p_) pt; + (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*) + (*drop the intermediate steps !*) + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end + else Steps (ScrState is, ss)) + + | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] => + raise error ("locate_gen: should not have got NasApp, ets =")*) + => NotLocatable + | NasNap (_,_) => + if l=[] then NotLocatable + else (*scan from begin of script for rew_only*) + (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b), + [(m,EmptyMout,pt,p,[])]) body of + Assoc (iss as (is as (_,_,_,_,_,bb), + ss as ((m',f',pt',p',c')::_))) => + ((*writeln"4### locate_gen Assoc after Fini";*) + if rew_only ss + then let val(p'',c'',f'',pt'') = + generate1 thy m (ScrState is) p' pt; + (*drop the intermediate steps !*) + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end + else NotLocatable) + | _ => ((*writeln ("#### locate_gen: after Fini");*) + NotLocatable)) + end + | locate_gen _ m _ (sc,_) is = + raise error ("locate_gen: wrong arguments,\n tac= "^(tac_2str m)^ + ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is)); + + + +(** find the next stactic in a script **) + +datatype appy = (*ExprVal in the sense of denotational semantics*) + Appy of (*applicable stac found, search stalled*) + tac_ * (*tac_ associated (fun assod) with stac*) + scrstate (*after determination of stac WN.18.8.03*) + | Napp of (*stac found was not applicable; + this mode may become Skip in Repeat, Try and Or*) + env (*stack*) (*popped while nxt_up*) + | Skip of (*for restart after Appy, for leaving iterations, + for passing the value of scriptexpressions, + and for finishing the script successfully*) + term * env (*stack*); + +(*appy, nxt_up, nstep_up scanning for next_tac. + search is clearly separated into (1)-(2): + (1) appy is recursive descent; + (2) nxt_up resumes interpretation at a location somewhere in the script; + nstep_up does only get to the parentnode of the scriptexpr. + consequence: + * call of (2) means _always_ that in this branch below + there was an applicable stac (Repeat, Or e1, ...) +*) + + +datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*) + (* Appy is only (final) returnvalue, not argument during search + |*) Napp_ (*ev. detects 'script is not appropriate for this example'*) + | Skip_; (*detects 'script successfully finished' + also used as init-value for resuming; this works, + because 'nxt_up Or e1' treats as Appy*) + +fun appy thy ptp E l + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v = +(* val (thy, ptp, E, l, t as Const ("Let",_) $ e $ (Abs (i,T,b)),a, v)= + (thy, ptp, E, up@[R,D], body, a, v); + appy thy ptp E l t a v; + *) + ((*writeln("### appy Let$e$Abs: is="); + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) + case appy thy ptp E (l@[L,R]) e a v of + Skip (res, E) => + let (*val _= writeln("### appy Let "^(term2str t)); + val _= writeln("### appy Let: Skip res ="^(term2str res));*) + (*val (i',b') = variant_abs (i,T,b); WN.15.5.03 + val i = mk_Free(i',T); WN.15.5.03 *) + val E' = upd_env E (Free (i,T), res); + in appy thy ptp E' (l@[R,D]) b a v end + | ay => ay) + + | appy (thy as (th,sr)) ptp E l + (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*) + ((*writeln("### appy While $ c $ e $ a, upd_env= "^ + (subst2str (upd_env E (a,v))));*) + if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c) + then appy thy ptp E (l@[L,R]) e (SOME a) v + else Skip (v, E)) + + | appy (thy as (th,sr)) ptp E l + (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*) + ((*writeln("### appy While $ c $ e, upd_env= "^ + (subst2str (upd_env_opt E (a,v))));*) + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) + then appy thy ptp E (l@[R]) e a v + else Skip (v, E)) + + | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v = + ((*writeln("### appy If: t= "^(term2str t)); + writeln("### appy If: c= "^(term2str(subst_atomic(upd_env_opt E(a,v))c))); + writeln("### appy If: thy= "^(fst thy));*) + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) + then ((*writeln("### appy If: true");*)appy thy ptp E (l@[L,R]) e1 a v) + else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v)) +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e $ a), _, v) = + (thy, ptp, E, (l@[R]), e, a, v); + *) + | appy thy ptp E (*env*) l + (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v = + ((*writeln("### appy Repeat a: ");*) + appy thy ptp E (*env*) (l@[L,R]) e (SOME a) v) +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e), _, v) = + (thy, ptp, E, (l@[R]), e, a, v); + *) + | appy thy ptp E (*env*) l + (Const ("Script.Repeat"(*2*),_) $ e) a v = + ((*writeln("3### appy Repeat: a= "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) a));*) + appy thy ptp E (*env*) (l@[R]) e a v) +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e $ a), _, v)= + (thy, ptp, E, (l@[R]), e2, a, v); + *) + | appy thy ptp E l + (t as Const ("Script.Try",_) $ e $ a) _ v = + (case appy thy ptp E (l@[L,R]) e (SOME a) v of + Napp E => ((*writeln("### appy Try "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + Skip (v, E)) + | ay => ay) +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)= + (thy, ptp, E, (l@[R]), e2, a, v); + val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)= + (thy, ptp, E, (l@[L,R]), e1, a, v); + *) + | appy thy ptp E l + (t as Const ("Script.Try",_) $ e) a v = + (case appy thy ptp E (l@[R]) e a v of + Napp E => ((*writeln("### appy Try "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + Skip (v, E)) + | ay => ay) + + + | appy thy ptp E l + (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v = + (case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of + Appy lme => Appy lme + | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (SOME a) v) + + | appy thy ptp E l + (Const ("Script.Or"(*2*),_) $e1 $ e2) a v = + (case appy thy ptp E (l@[L,R]) e1 a v of + Appy lme => Appy lme + | _ => appy thy ptp E (l@[R]) e2 a v) + +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)= + (thy, ptp, E,(up@[R]),e2, a, v); + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)= + (thy, ptp, E,(up@[R,D]),body, a, v); + *) + | appy thy ptp E l + (Const ("Script.Seq"(*1*),_) $ e1 $ e2 $ a) _ v = + ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^ + (subst2str (upd_env E (a,v))));*) + case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of + Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (SOME a) v + | ay => ay) + +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= + (thy, ptp, E,(up@[R]),e2, a, v); + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= + (thy, ptp, E,(l@[R]), e2, a, v); + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= + (thy, ptp, E,(up@[R,D]),body, a, v); + *) + | appy thy ptp E l + (Const ("Script.Seq",_) $ e1 $ e2) a v = + (case appy thy ptp E (l@[L,R]) e1 a v of + Skip (v,E) => appy thy ptp E (l@[R]) e2 a v + | ay => ay) + + (*.a leaf has been found*) + | appy (thy as (th,sr)) (pt, p) E l t a v = +(* val (thy as (th,sr),(pt, p),E, l, t, a, v) = + (thy, ptp, E, up@[R,D], body, a, v); + val (thy as (th,sr),(pt, p),E, l, t, a, v) = + (thy, ptp, E, l@[L,R], e, a, v); + val (thy as (th,sr),(pt, p),E, l, t, a, v) = + (thy, ptp, E,(l@[R]), e, a, v); + *) + (case handle_leaf "next " th sr E a v t of +(* val (a', Expr s) = handle_leaf "next " th sr E a v t; + *) + (a', Expr s) => Skip (s, E) +(* val (a', STac stac) = handle_leaf "next " th sr E a v t; + *) + | (a', STac stac) => + let + (*val _= writeln("### appy t, vor stac2tac_ is="); + val _= writeln(istate2str (ScrState (E,l,a',v,Sundef,false)));*) + val (m,m') = stac2tac_ pt (assoc_thy th) stac + in case m of + Subproblem _ => Appy (m', (E,l,a',tac_2res m',Sundef,false)) + | _ => (case applicable_in p pt m of +(* val Appl m' = applicable_in p pt m; + *) + Appl m' => + ((*writeln("### appy: Appy");*) + Appy (m', (E,l,a',tac_2res m',Sundef,false))) + | _ => ((*writeln("### appy: Napp");*)Napp E)) + end); + + +(* val (scr as Script sc, l, t as Const ("Let",_) $ _) = + (Script sc, up, go up sc); + nxt_up thy ptp (Script sc) E l ay t a v; + + val (thy,ptp,scr as (Script sc),E,l, ay, t as Const ("Let",_) $ _, a, v)= + (thy,ptp,Script sc, E,up,ay, go up sc, a, v); + nxt_up thy ptp scr E l ay t a v; + *) +fun nxt_up thy ptp (scr as (Script sc)) E l ay + (t as Const ("Let",_) $ _) a v = (*comes from let=...*) + ((*writeln("### nxt_up1 Let$e: is="); + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) + if ay = Napp_ + then nstep_up thy ptp scr E (drop_last l) Napp_ a v + else (*Skip_*) + let val up = drop_last l; + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc; + val i = mk_Free (i, T); + val E = upd_env E (i, v); + (*val _= writeln("### nxt_up2 Let$e: is="); + val _= writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) + in case appy thy ptp (E) (up@[R,D]) body a v of + Appy lre => Appy lre + | Napp E => nstep_up thy ptp scr E up Napp_ a v + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end) + + | nxt_up thy ptp scr E l ay + (t as Abs (_,_,_)) a v = + ((*writeln("### nxt_up Abs: "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + nstep_up thy ptp scr E (*enr*) l ay a v) + + | nxt_up thy ptp scr E l ay + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v = + ((*writeln("### nxt_up Let$e$Abs: is="); + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) + (*writeln("### nxt_up Let e Abs: "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + nstep_up thy ptp scr (*upd_env*) E (*a,v)*) + (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v) + + (*no appy_: never causes Napp -> Helpless*) + | nxt_up (thy as (th,sr)) ptp scr E l _ + (Const ("Script.While"(*1*),_) $ c $ e $ _) a v = + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) + then case appy thy ptp E (l@[L,R]) e a v of + Appy lr => Appy lr + | Napp E => nstep_up thy ptp scr E l Skip_ a v + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v + else nstep_up thy ptp scr E l Skip_ a v + + (*no appy_: never causes Napp - Helpless*) + | nxt_up (thy as (th,sr)) ptp scr E l _ + (Const ("Script.While"(*2*),_) $ c $ e) a v = + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) + then case appy thy ptp E (l@[R]) e a v of + Appy lr => Appy lr + | Napp E => nstep_up thy ptp scr E l Skip_ a v + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v + else nstep_up thy ptp scr E l Skip_ a v + +(* val (scr, l) = (Script sc, up); + *) + | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v = + nstep_up thy ptp scr E l ay a v + + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*) + (Const ("Script.Repeat"(*1*),T) $ e $ _) a v = + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of + Appy lr => Appy lr + | Napp E => ((*writeln("### nxt_up Repeat a: ");*) + nstep_up thy ptp scr E l Skip_ a v) + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^ + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*) + nstep_up thy ptp scr E l Skip_ a v)) + + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*) + (Const ("Script.Repeat"(*2*),T) $ e) a v = + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of + Appy lr => Appy lr + | Napp E => ((*writeln("### nxt_up Repeat a: ");*) + nstep_up thy ptp scr E l Skip_ a v) + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^ + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*) + nstep_up thy ptp scr E l Skip_ a v)) +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e $ _), a, v) = + (thy, ptp, (Script sc), + E, up, ay,(go up sc), a, v); + *) + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*) + (t as Const ("Script.Try",_) $ e $ _) a v = + ((*writeln("### nxt_up Try "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + nstep_up thy ptp scr E l Skip_ a v ) +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e), a, v) = + (thy, ptp, (Script sc), + E, up, ay,(go up sc), a, v); + *) + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*) + (t as Const ("Script.Try"(*2*),_) $ e) a v = + ((*writeln("### nxt_up Try "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) + nstep_up thy ptp scr E l Skip_ a v) + + + | nxt_up thy ptp scr E l ay + (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v + + | nxt_up thy ptp scr E l ay + (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v + + | nxt_up thy ptp scr E l ay + (Const ("Script.Or",_) $ _ ) a v = + nstep_up thy ptp scr E (drop_last l) ay a v +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ _ $ _), a, v) = + (thy, ptp, (Script sc), + E, up, ay,(go up sc), a, v); + *) + | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*) + (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v = + nstep_up thy ptp scr E l ay a v +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ e2), a, v) = + (thy, ptp, (Script sc), + E, up, ay,(go up sc), a, v); + *) + | nxt_up thy ptp scr E l ay (*comes from e2*) + (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v = + nstep_up thy ptp scr E l ay a v +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _), a, v) = + (thy, ptp, (Script sc), + E, up, ay,(go up sc), a, v); + *) + | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*) + (Const ("Script.Seq",_) $ _) a v = + if ay = Napp_ + then nstep_up thy ptp scr E (drop_last l) Napp_ a v + else (*Skip_*) + let val up = drop_last l; + val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc; + in case appy thy ptp E (up@[R]) e2 a v of + Appy lr => Appy lr + | Napp E => nstep_up thy ptp scr E up Napp_ a v + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end + + | nxt_up (thy,_) ptp scr E l ay t a v = + raise error ("nxt_up not impl for "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)) + +(* val (thy, ptp, (Script sc), E, l, ay, a, v)= + (thy, ptp, scr, E, l, Skip_, a, v); + val (thy, ptp, (Script sc), E, l, ay, a, v)= + (thy, ptp, sc, E, l, Skip_, a, v); + *) +and nstep_up thy ptp (Script sc) E l ay a v = + ((*writeln("### nstep_up from: "^(loc_2str l)); + writeln("### nstep_up from: "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go l sc)));*) + if 1 < length l + then + let + val up = drop_last l; + in ((*writeln("### nstep_up to: "^ + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go up sc)));*) + nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end + else (*interpreted to end*) + if ay = Skip_ then Skip (v, E) else Napp E +); + +(* decide for the next applicable stac in the script; + returns (stactic, value) - the value in case the script is finished + 12.8.02: ~~~~~ and no assumptions ??? FIXME ??? + 20.8.02: must return p in case of finished, because the next script + consulted need not be the calling script: + in case of detail ie. _inserted_ PrfObjs, the next stac + has to searched in a script with PblObj.status<>Complete ! + (.. not true for other details ..PrfObj ?????????????????? + 20.8.02: do NOT return safe (is only changed in locate !!!) +*) +(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) = + (thy', (pt,p), sc, RrlsState (ii t)); + val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) = + (thy', (pt',p'), sc, is'); + *) +fun next_tac (thy,_) (pt,p) (Rfuns {next_rule,...}) (RrlsState(f,f',rss,_))= + if f = f' then (End_Detail' (f',[])(*8.6.03*), Uistate, + (f', Sundef(*FIXME is no value of next_tac! vor 8.6.03*))) + (*finished*) + else (case next_rule rss f of + NONE => (Empty_Tac_, Uistate, (e_term, Sundef)) (*helpless*) +(* val SOME (Thm (id,thm)) = next_rule rss f; + *) + | SOME (Thm (id,thm))(*8.6.03: muss auch f' liefern ?!!*) => + (Rewrite' (thy, "e_rew_ord", e_rls,(*!?!8.6.03*) false, + (id, string_of_thmI thm), f,(e_term,[(*!?!8.6.03*)])), + Uistate, (e_term, Sundef))) (*next stac*) + +(* val(thy, ptp as (pt,(p,_)), sc as Script (h $ body),ScrState (E,l,a,v,s,b))= + ((thy',srls), (pt,pos), sc, is); + *) + | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body)) + (ScrState (E,l,a,v,s,b)) = + ((*writeln("### next_tac-----------------: E= "); + writeln( istate2str (ScrState (E,l,a,v,s,b)));*) + case if l=[] then appy thy ptp E [R] body NONE v + else nstep_up thy ptp sc E l Skip_ a v of + Skip (v,_) => (*finished*) + (case par_pbl_det pt p of + (true, p', _) => + let val (_,pblID,_) = get_obj g_spec pt p'; + in (Check_Postcond' (pblID, (v, [(*8.6.03 NO asms???*)])), + e_istate, (v,s)) end + | (_,p',rls') => (End_Detail' (e_term,[])(*8.6.03*), e_istate, (v,s))) + | Napp _ => (Empty_Tac_, e_istate, (e_term, Sundef)) (*helpless*) + | Appy (m', scrst as (_,_,_,v,_,_)) => (m', ScrState scrst, + (v, Sundef))) (*next stac*) + + | next_tac _ _ _ is = raise error ("next_tac: not impl for "^ + (istate2str is)); + + + + +(*.create the initial interpreter state from the items of the guard.*) +(* val (thy, itms, metID) = (thy, itms, mI); + *) +fun init_scrstate thy itms metID = + let val actuals = itms2args thy metID itms; + val scr as Script sc = (#scr o get_met) metID; + val formals = formal_args sc + (*expects same sequence of (actual) args in itms + and (formal) args in met*) + fun relate_args env [] [] = env + | relate_args env _ [] = + raise error ("ERROR in creating the environment for '" + ^id_of_scr sc^"' from \nthe items of the guard of " + ^metID2str metID^",\n\ + \formal arg(s), from the script,\ + \ miss actual arg(s), from the guards env:\n" + ^(string_of_int o length) formals + ^" formals: "^terms2str formals^"\n" + ^(string_of_int o length) actuals + ^" actuals: "^terms2str actuals) + | relate_args env [] actual_finds = env (*may drop Find!*) + | relate_args env (a::aa) (f::ff) = + if type_of a = type_of f + then relate_args (env @ [(a, f)]) aa ff else + raise error ("ERROR in creating the environment for '" + ^id_of_scr sc^"' from \nthe items of the guard of " + ^metID2str metID^",\n\ + \different types of formal arg, from the script,\ + \ and actual arg, from the guards env:'\n\ + \formal: '"^term2str a^"::"^(type2str o type_of) a^"'\n\ + \actual: '"^term2str f^"::"^(type2str o type_of) f^"'\n\ + \in\n\ + \formals: "^terms2str formals^"\n\ + \actuals: "^terms2str actuals) + val env = relate_args [] formals actuals; + in (ScrState (env,[],NONE,e_term,Safe,true), scr):istate * scr end; + +(*.decide, where to get script/istate from: + (*1*) from PblObj.env: at begin of script if no init_form + (*2*) from PblObj/PrfObj: if stac is in the middle of the script + (*3*) from rls/PrfObj: in case of detail a ruleset.*) +(* val (thy', (p,p_), pt) = (thy', (p,p_), pt); + *) +fun from_pblobj_or_detail' thy' (p,p_) pt = + if member op = [Pbl,Met] p_ + then case get_obj g_env pt p of + NONE => raise error "from_pblobj_or_detail': no istate" + | SOME is => + let val metID = get_obj g_metID pt p + val {srls,...} = get_met metID + in (srls, is, (#scr o get_met) metID) end + else + let val (pbl,p',rls') = par_pbl_det pt p + in if pbl + then (*2*) + let val thy = assoc_thy thy' + val PblObj{meth=itms,...} = get_obj I pt p' + val metID = get_obj g_metID pt p' + val {srls,...} = get_met metID + in (*if last_elem p = 0 (*nothing written to pt yet*) + then let val (is, sc) = init_scrstate thy itms metID + in (srls, is, sc) end + else*) (srls, get_istate pt (p,p_), (#scr o get_met) metID) + end + else (*3*) + (e_rls, (*FIXME: get from pbl or met !!! + unused for Rrls in locate_gen, next_tac*) + get_istate pt (p,p_), + case rls' of + Rls {scr=scr,...} => scr + | Seq {scr=scr,...} => scr + | Rrls {scr=rfuns,...} => rfuns) + end; + +(*.get script and istate from PblObj, see (*1*) above.*) +fun from_pblobj' thy' (p,p_) pt = + let val p' = par_pblobj pt p + val thy = assoc_thy thy' + val PblObj{meth=itms,...} = get_obj I pt p' + val metID = get_obj g_metID pt p' + val {srls,scr,...} = get_met metID + in if last_elem p = 0 (*nothing written to pt yet*) + then let val (is, scr) = init_scrstate thy itms metID + in (srls, is, scr) end + else (srls, get_istate pt (p,p_), scr) + end; + +(*.get the stactics and problems of a script as tacs + instantiated with the current environment; + l is the location which generated the given formula.*) +(*WN.12.5.03: quick-and-dirty repair for listexpressions*) +fun is_spec_pos Pbl = true + | is_spec_pos Met = true + | is_spec_pos _ = false; + +(*. fetch _all_ tactics from script .*) +fun sel_rules _ (([],Res):pos') = + raise PTREE "no tactics applicable at the end of a calculation" +| sel_rules pt (p,p_) = + if is_spec_pos p_ + then [get_obj g_tac pt p] + else + let val pp = par_pblobj pt p; + val thy' = (get_obj g_domID pt pp):theory'; + val thy = assoc_thy thy'; + val metID = get_obj g_metID pt pp; + val metID' =if metID =e_metID then(thd3 o snd3)(get_obj g_origin pt pp) + else metID + val {scr=Script sc,srls,...} = get_met metID' + val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_); + in map ((stac2tac pt thy) o rep_stacexpr o #2 o + (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) end; +(* +> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test"); +> val env = [((term_of o the o (parse Isac.thy)) "bdv", + (term_of o the o (parse Isac.thy)) "x")]; +> map ((stac2tac pt thy) o #2 o(subst_stacexpr env NONE e_term)) (stacpbls sc); +*) + + +(*. fetch tactics from script and filter _applicable_ tactics; + in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*) +fun sel_appl_atomic_tacs _ (([],Res):pos') = + raise PTREE "no tactics applicable at the end of a calculation" + | sel_appl_atomic_tacs pt (p,p_) = + if is_spec_pos p_ + then [get_obj g_tac pt p] + else + let val pp = par_pblobj pt p + val thy' = (get_obj g_domID pt pp):theory' + val thy = assoc_thy thy' + val metID = get_obj g_metID pt pp + val metID' =if metID = e_metID + then (thd3 o snd3) (get_obj g_origin pt pp) + else metID + val {scr=Script sc,srls,erls,rew_ord'=ro,...} = get_met metID' + val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_) + val alltacs = (*we expect at least 1 stac in a script*) + map ((stac2tac pt thy) o rep_stacexpr o #2 o + (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) + val f = case p_ of + Frm => get_obj g_form pt p + | Res => (fst o (get_obj g_result pt)) p + (*WN071231 ? replace atomic_appl_tacs with applicable_in (ineff!) ?*) + in (distinct o flat o + (map (atomic_appl_tacs thy ro erls f))) alltacs end; + + +(* +end +open Interpreter; +*) + +(* use"ME/script.sml"; + use"script.sml"; + *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Interpret/solve.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Interpret/solve.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,579 @@ +(* solve an example by interpreting a method's script + (c) Walther Neuper 1999 + +use"ME/solve.sml"; +use"solve.sml"; +*) + +fun safe (ScrState (_,_,_,_,s,_)) = s + | safe (RrlsState _) = Safe; + +type mstID = string; +type tac'_ = mstID * tac; (*DG <-> ME*) +val e_tac'_ = ("Empty_Tac", Empty_Tac):tac'_; + +fun mk_tac'_ m = case m of + Init_Proof (ppc, spec) => ("Init_Proof", Init_Proof (ppc, spec )) +| Model_Problem => ("Model_Problem", Model_Problem) +| Refine_Tacitly pblID => ("Refine_Tacitly", Refine_Tacitly pblID) +| Refine_Problem pblID => ("Refine_Problem", Refine_Problem pblID) +| Add_Given cterm' => ("Add_Given", Add_Given cterm') +| Del_Given cterm' => ("Del_Given", Del_Given cterm') +| Add_Find cterm' => ("Add_Find", Add_Find cterm') +| Del_Find cterm' => ("Del_Find", Del_Find cterm') +| Add_Relation cterm' => ("Add_Relation", Add_Relation cterm') +| Del_Relation cterm' => ("Del_Relation", Del_Relation cterm') + +| Specify_Theory domID => ("Specify_Theory", Specify_Theory domID) +| Specify_Problem pblID => ("Specify_Problem", Specify_Problem pblID) +| Specify_Method metID => ("Specify_Method", Specify_Method metID) +| Apply_Method metID => ("Apply_Method", Apply_Method metID) +| Check_Postcond pblID => ("Check_Postcond", Check_Postcond pblID) +| Free_Solve => ("Free_Solve",Free_Solve) + +| Rewrite_Inst (subs, thm') => ("Rewrite_Inst", Rewrite_Inst (subs, thm')) +| Rewrite thm' => ("Rewrite", Rewrite thm') +| Rewrite_Asm thm' => ("Rewrite_Asm", Rewrite_Asm thm') +| Rewrite_Set_Inst (subs, rls') + => ("Rewrite_Set_Inst", Rewrite_Set_Inst (subs, rls')) +| Rewrite_Set rls' => ("Rewrite_Set", Rewrite_Set rls') +| End_Ruleset => ("End_Ruleset", End_Ruleset) + +| End_Detail => ("End_Detail", End_Detail) +| Detail_Set rls' => ("Detail_Set", Detail_Set rls') +| Detail_Set_Inst (s, rls') => ("Detail_Set_Inst", Detail_Set_Inst (s, rls')) + +| Calculate op_ => ("Calculate", Calculate op_) +| Substitute sube => ("Substitute", Substitute sube) +| Apply_Assumption cts' => ("Apply_Assumption", Apply_Assumption cts') + +| Take cterm' => ("Take", Take cterm') +| Take_Inst cterm' => ("Take_Inst", Take_Inst cterm') +| Group (con, ints) => ("Group", Group (con, ints)) +| Subproblem (domID, pblID) => ("Subproblem", Subproblem (domID, pblID)) +(* +| Subproblem_Full(spec,cts')=> ("Subproblem_Full", Subproblem_Full(spec,cts')) +*) +| End_Subproblem => ("End_Subproblem",End_Subproblem) +| CAScmd cterm' => ("CAScmd", CAScmd cterm') + +| Split_And => ("Split_And", Split_And) +| Conclude_And => ("Conclude_And", Conclude_And) +| Split_Or => ("Split_Or", Split_Or) +| Conclude_Or => ("Conclude_Or", Conclude_Or) +| Begin_Trans => ("Begin_Trans", Begin_Trans) +| End_Trans => ("End_Trans", End_Trans) +| Begin_Sequ => ("Begin_Sequ", Begin_Sequ) +| End_Sequ => ("End_Sequ", Begin_Sequ) +| Split_Intersect => ("Split_Intersect", Split_Intersect) +| End_Intersect => ("End_Intersect", End_Intersect) +| Check_elementwise cterm' => ("Check_elementwise", Check_elementwise cterm') +| Or_to_List => ("Or_to_List", Or_to_List) +| Collect_Trues => ("Collect_Results", Collect_Trues) + +| Empty_Tac => ("Empty_Tac",Empty_Tac) +| Tac string => ("Tac",Tac string) +| User => ("User",User) +| End_Proof' => ("End_Proof'",End_Proof'); + +(*Detail*) +val empty_tac'_ = (mk_tac'_ Empty_Tac):tac'_; + +fun mk_tac ((_,m):tac'_) = m; +fun mk_mstID ((mI,_):tac'_) = mI; + +fun tac'_2str ((ID,ms):tac'_) = ID ^ (tac2str ms); +(* TODO: tac2str, tac'_2str NOT tested *) + + + +type squ = ptree; (* TODO: safe etc. *) + +(*13.9.02-------------- +type ctr = (loc * pos) list; +val ops = [("PLUS","op +"),("minus","op -"),("TIMES","op *"), + ("cancel","cancel"),("pow","pow"),("sqrt","sqrt")]; +fun op_intern op_ = + case assoc (ops,op_) of + SOME op' => op' | NONE => raise error ("op_intern: no op= "^op_); +-----------------------*) + + + +(* use"ME/solve.sml"; + use"solve.sml"; + +val ttt = (term_of o the o (parse thy))"Substitute [(bdv,x)] g"; +val ttt = (term_of o the o (parse thy))"Rewrite thmid True g"; + + Const ("Script.Rewrite'_Inst",_) $ sub $ Free (thm',_) $ Const (pa,_) $ f' + *) + + + +val specsteps = ["Init_Proof","Refine_Tacitly","Refine_Problem", + "Model_Problem",(*"Match_Problem",*) + "Add_Given","Del_Given","Add_Find","Del_Find", + "Add_Relation","Del_Relation", + "Specify_Theory","Specify_Problem","Specify_Method"]; + +"-----------------------------------------------------------------------"; + + +fun step2taci ((tac_, _, pt, p, _):step) = (*FIXXME.040312: redesign step*) + (tac_2tac tac_, tac_, (p, get_istate pt p)):taci; + + +(*FIXME.WN050821 compare solve ... nxt_solv*) +(* val ("Apply_Method",Apply_Method' (mI,_))=(mI,m); + val (("Apply_Method",Apply_Method' (mI,_,_)),pt, pos as (p,_))=(m,pt, pos); + *) +fun solve ("Apply_Method", m as Apply_Method' (mI, _, _)) + (pt:ptree, (pos as (p,_))) = + let val {srls,...} = get_met mI; + val PblObj{meth=itms,...} = get_obj I pt p; + val thy' = get_obj g_domID pt p; + val thy = assoc_thy thy'; + val (is as ScrState (env,_,_,_,_,_), sc) = init_scrstate thy itms mI; + val ini = init_form thy sc env; + val p = lev_dn p; + in + case ini of + SOME t => (* val SOME t = ini; + *) + let val (pos,c,_,pt) = + generate1 thy (Apply_Method' (mI, SOME t, is)) + is (lev_on p, Frm)(*implicit Take*) pt; + in ("ok",([(Apply_Method mI, Apply_Method' (mI, SOME t, is), + ((lev_on p, Frm), is))], c, (pt,pos)):calcstate') + end + | NONE => (*execute the first tac in the Script, compare solve m*) + let val (m', is', _) = next_tac (thy', srls) (pt, (p, Res)) sc is; + val d = e_rls (*FIXME: get simplifier from domID*); + in + case locate_gen (thy',srls) m' (pt,(p, Res))(sc,d) is' of + Steps (is'', ss as (m'',f',pt',p',c')::_) => +(* val Steps (is'', ss as (m'',f',pt',p',c')::_) = + locate_gen (thy',srls) m' (pt,(p,Res)) (sc,d) is'; + *) + ("ok", (map step2taci ss, c', (pt',p'))) + | NotLocatable => + let val (p,ps,f,pt) = + generate_hard (assoc_thy "Isac.thy") m (p,Frm) pt; + in ("not-found-in-script", + ([(tac_2tac m, m, (pos, is))], ps, (pt,p))) end + (*just-before------------------------------------------------------ + ("ok",([(Apply_Method mI,Apply_Method'(mI,NONE,e_istate), + (pos, is))], + [], (update_env pt (fst pos) (SOME is),pos))) + -----------------------------------------------------------------*) + end + end + + | solve ("Free_Solve", Free_Solve') (pt,po as (p,_)) = + let (*val _=writeln"###solve Free_Solve";*) + val p' = lev_dn_ (p,Res); + val pt = update_metID pt (par_pblobj pt p) e_metID; + in ("ok", ((*(p',Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Unsafe,*) + [(Empty_Tac, Empty_Tac_, (po, Uistate))], [], (pt,p'))) end + +(* val (("Check_Postcond",Check_Postcond' (pI,_)), (pt,(pos as (p,p_)))) = + ( m, (pt, pos)); + *) + | solve ("Check_Postcond",Check_Postcond' (pI,_)) (pt,(pos as (p,p_))) = + let (*val _=writeln"###solve Check_Postcond";*) + val pp = par_pblobj pt p + val asm = (case get_obj g_tac pt p of + Check_elementwise _ => (*collects and instantiates asms*) + (snd o (get_obj g_result pt)) p + | _ => ((map fst) o (get_assumptions_ pt)) (p,p_)) + handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*) + val metID = get_obj g_metID pt pp; + val {srls=srls,scr=sc,...} = get_met metID; + val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_); + (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_))); + val _= writeln("### solve Check_postc, is= "^(istate2str is));*) + val thy' = get_obj g_domID pt pp; + val thy = assoc_thy thy'; + val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is; + (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*) + + in if pp = [] then + let val is = ScrState (E,l,a,scval,scsaf,b) + val tac_ = Check_Postcond'(pI,(scval, map term2str asm)) + val (pos,ps,f,pt) = generate1 thy tac_ is (pp,Res) pt; + in ("ok", ((*(([],Res),is,End_Proof''), f, End_Proof', scsaf,*) + [(Check_Postcond pI, tac_, ((pp,Res),is))], ps,(pt,pos))) end + else + let + (*resume script of parpbl, transfer value of subpbl-script*) + val ppp = par_pblobj pt (lev_up p); + val thy' = get_obj g_domID pt ppp; + val thy = assoc_thy thy'; + val metID = get_obj g_metID pt ppp; + val sc = (#scr o get_met) metID; + val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm); + (*val _=writeln("### solve Check_postc, parpbl pos= "^(pos'2str(pp,Frm))); + val _=writeln("### solve Check_postc, is(pt)= "^(istate2str is)); + val _=writeln("### solve Check_postc, is'= "^ + (istate2str (E,l,a,scval,scsaf,b)));*) + val ((p,p_),ps,f,pt) = + generate1 thy (Check_Postcond' (pI, (scval, map term2str asm))) + (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt; + (*val _=writeln("### solve Check_postc, is(pt')= "^ + (istate2str (get_istate pt ([3],Res)))); + val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) sc + (ScrState (E,l,a,scval,scsaf,b));*) + in ("ok",(*((pp,Res),is',nx), f, tac_2tac nx, scsaf,*) + ([(Check_Postcond pI, Check_Postcond'(pI,(scval, map term2str asm)), + ((pp,Res), ScrState (E,l,a,scval,scsaf,b)))],ps,(pt,(p,p_)))) + end + end +(* val (msg, cs') = + ("ok",([(Check_Postcond pI,Check_Postcond'(pI, (scval, map term2str asm))), + ((pp,Res),(ScrState (E,l,a,scval,scsaf,b)))], (pt,(p,p_)))); + val (_,(pt',p')) = cs'; + (writeln o istate2str) (get_istate pt' p'); + (term2str o fst) (get_obj g_result pt' (fst p')); + *) + +(* writeln(istate2str(get_istate pt (p,p_))); + *) + | solve (_,End_Proof'') (pt, (p,p_)) = + ("end-proof", + ((*(([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe,*) + [(Empty_Tac,Empty_Tac_,(([],Res),Uistate))],[],(pt,(p,p_)))) + +(*-----------vvvvvvvvvvv could be done by generate1 ?!?*) + | solve (_,End_Detail' t) (pt,(p,p_)) = + let val pr as (p',_) = (lev_up p, Res) + val pp = par_pblobj pt p + val r = (fst o (get_obj g_result pt)) p' + (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*) + val thy' = get_obj g_domID pt pp + val (srls, is, sc) = from_pblobj' thy' pr pt + val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is + in ("ok", ((*((pp,Frm(*???*)),is,tac_), + Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)), + tac_2tac tac_, Sundef,*) + [(End_Detail, End_Detail' t , + ((p,p_), get_istate pt (p,p_)))], [], (pt,pr))) end + + | solve (mI,m) (pt, po as (p,p_)) = +(* val ((mI,m), (pt, po as (p,p_))) = (m, (pt, pos)); + *) + if e_metID = get_obj g_metID pt (par_pblobj pt p)(*29.8.02: + could be detail, too !!*) + then let val ((p,p_),ps,f,pt) = + generate1 (assoc_thy (get_obj g_domID pt (par_pblobj pt p))) + m e_istate (p,p_) pt; + in ("no-method-specified", (*Free_Solve*) + ((*((p,p_),Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*) + [(Empty_Tac,Empty_Tac_, ((p,p_),Uistate))], ps, (pt,(p,p_)))) end + else + let + val thy' = get_obj g_domID pt (par_pblobj pt p); + val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt; +(*val _= writeln("### solve, before locate_gen p="^(pos'2str(p,p_)));*) + val d = e_rls; (*FIXME: canon.simplifier for domain is missing + 8.01: generate from domID?*) + in case locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is of + Steps (is', ss as (m',f',pt',p',c')::_) => +(* val Steps (is', ss as (m',f',pt',p',c')::_) = + locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is; + *) + let (*val _= writeln("### solve, after locate_gen: is= ") + val _= writeln(istate2str is')*) + (*val nxt_ = + case p' of (*change from solve to model subpbl*) + (_,Pbl) => nxt_model_pbl m' (pt',p') + | _ => fst3 (next_tac (thy',srls) (pt',p') sc is');*) + (*27.8.02:next_tac may change to other branches in pt FIXXXXME*) + in ("ok", ((*(p',is',nxt_), f', tac_2tac nxt_, safe is',*) + map step2taci ss, c', (pt',p'))) end + | NotLocatable => + let val (p,ps,f,pt) = + generate_hard (assoc_thy "Isac.thy") m (p,p_) pt; + in ("not-found-in-script", + ((*(p,Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*) + [(tac_2tac m, m, (po,is))], ps, (pt,p))) end + end; + + +(*FIXME.WN050821 compare solve ... nxt_solv*) +(* nxt_solv (Apply_Method' vvv FIXME: get args in applicable_in *) +fun nxt_solv (Apply_Method' (mI,_,_)) _ (pt:ptree, pos as (p,_)) = +(* val ((Apply_Method' (mI,_,_)), _, (pt:ptree, pos as (p,_))) = + ((Apply_Method' (mI, NONE, e_istate)), e_istate, ptp); + *) + let val {srls,ppc,...} = get_met mI; + val PblObj{meth=itms,origin=(oris,_,_),probl,...} = get_obj I pt p; + val itms = if itms <> [] then itms + else complete_metitms oris probl [] ppc + val thy' = get_obj g_domID pt p; + val thy = assoc_thy thy'; + val (is as ScrState (env,_,_,_,_,_), scr) = init_scrstate thy itms mI; + val ini = init_form thy scr env; + in + case ini of + SOME t => (* val SOME t = ini; + *) + let val pos = ((lev_on o lev_dn) p, Frm) + val tac_ = Apply_Method' (mI, SOME t, is); + val (pos,c,_,pt) = (*implicit Take*) + generate1 thy tac_ is pos pt + (*val _= ("### nxt_solv Apply_Method, pos= "^pos'2str (lev_on p,Frm));*) + in ([(Apply_Method mI, tac_, (pos, is))], c, (pt, pos)):calcstate' end + | NONE => + let val pt = update_env pt (fst pos) (SOME is) + val (tacis, c, ptp) = nxt_solve_ (pt, pos) + in (tacis @ + [(Apply_Method mI, Apply_Method' (mI, NONE, e_istate), (pos, is))], + c, ptp) end + end +(* val ("Check_Postcond",Check_Postcond' (pI,_)) = (mI,m); + val (Check_Postcond' (pI,_), _, (pt, pos as (p,p_))) = + (tac_, is, ptp); + *) + (*TODO.WN050913 remove unnecessary code below*) + | nxt_solv (Check_Postcond' (pI,_)) _ (pt, pos as (p,p_)) = + let (*val _=writeln"###solve Check_Postcond";*) + val pp = par_pblobj pt p + val asm = (case get_obj g_tac pt p of + Check_elementwise _ => (*collects and instantiates asms*) + (snd o (get_obj g_result pt)) p + | _ => ((map fst) o (get_assumptions_ pt)) (p,p_)) + handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*) + val metID = get_obj g_metID pt pp; + val {srls=srls,scr=sc,...} = get_met metID; + val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_); + (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_))); + val _= writeln("### solve Check_postc, is= "^(istate2str is));*) + val thy' = get_obj g_domID pt pp; + val thy = assoc_thy thy'; + val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is; + (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*) + in if pp = [] then + let val is = ScrState (E,l,a,scval,scsaf,b) + val tac_ = Check_Postcond'(pI,(scval, map term2str asm)) + (*val _= writeln"### nxt_solv2 Apply_Method: stored is ="; + val _= writeln(istate2str is);*) + val ((p,p_),ps,f,pt) = + generate1 thy tac_ is (pp,Res) pt; + in ([(Check_Postcond pI, tac_, ((pp,Res), is))],ps,(pt, (p,p_))) end + else + let + (*resume script of parpbl, transfer value of subpbl-script*) + val ppp = par_pblobj pt (lev_up p); + val thy' = get_obj g_domID pt ppp; + val thy = assoc_thy thy'; + val metID = get_obj g_metID pt ppp; + val {scr,...} = get_met metID; + val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm) + val tac_ = Check_Postcond' (pI, (scval, map term2str asm)) + val is = ScrState (E,l,a,scval,scsaf,b) + (*val _= writeln"### nxt_solv3 Apply_Method: stored is ="; + val _= writeln(istate2str is);*) + val ((p,p_),ps,f,pt) = generate1 thy tac_ is (pp, Res) pt; + (*val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) scr is;WN050913*) + in ([(Check_Postcond pI, tac_, ((pp, Res), is))], ps, (pt, (p,p_))) end + end +(* writeln(istate2str(get_istate pt (p,p_))); + *) + +(*.start interpreter and do one rewrite.*) +(* val (_,Detail_Set'(thy',rls,t)) = (mI,m); val p = (p,p_); + solve ("",Detail_Set'(thy', rls, t)) p pt; + | nxt_solv (Detail_Set'(thy', rls, t)) _ (pt, p) = ********** +---> Frontend/sml.sml + + | nxt_solv (End_Detail' t) _ (pt, (p,p_)) = ********** + let val pr as (p',_) = (lev_up p, Res) + val pp = par_pblobj pt p + val r = (fst o (get_obj g_result pt)) p' + (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*) + val thy' = get_obj g_domID pt pp + val (srls, is, sc) = from_pblobj' thy' pr pt + val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is + in (pr, ((pp,Frm(*???*)),is,tac_), + Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)), + tac_2tac tac_, Sundef, pt) end +*) + | nxt_solv (End_Proof'') _ ptp = ([], [], ptp) + + | nxt_solv tac_ is (pt, pos as (p,p_)) = +(* val (pt, pos as (p,p_)) = ptp; + *) + let val pos = case pos of + (p, Met) => ((lev_on o lev_dn) p, Frm)(*begin script*) + | (p, Res) => (lev_on p,Res) (*somewhere in script*) + | _ => pos (*somewhere in script*) + (*val _= writeln"### nxt_solv4 Apply_Method: stored is ="; + val _= writeln(istate2str is);*) + val (pos',c,_,pt) = generate1 (assoc_thy "Isac.thy") tac_ is pos pt; + in ([(tac_2tac tac_, tac_, (pos,is))], c, (pt, pos')) end + + + (*(p,p_), (([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe, pt*) + + +(*.find the next tac from the script, nxt_solv will update the ptree.*) +(* val (ptp as (pt,pos as (p,p_))) = ptp'; + val (ptp as (pt, pos as (p,p_))) = ptp''; + val (ptp as (pt, pos as (p,p_))) = ptp; + val (ptp as (pt, pos as (p,p_))) = (pt,ip); + val (ptp as (pt, pos as (p,p_))) = (pt, pos); + *) +and nxt_solve_ (ptp as (pt, pos as (p,p_))) = + if e_metID = get_obj g_metID pt (par_pblobj pt p) + then ([], [], (pt,(p,p_))):calcstate' + else let val thy' = get_obj g_domID pt (par_pblobj pt p); + val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt; + val (tac_,is,(t,_)) = next_tac (thy',srls) (pt,pos) sc is; + (*TODO here ^^^ return finished/helpless/ok !*) + (* val (tac_',is',(t',_)) = next_tac (thy',srls) (pt,pos) sc is; + *) + in case tac_ of + End_Detail' _ => ([(End_Detail, + End_Detail' (t,[(*FIXME.040215*)]), + (pos, is))], [], (pt, pos)) + | _ => nxt_solv tac_ is ptp end; + +(*.says how may steps of a calculation should be done by "fun autocalc".*) +(*TODO.WN0512 redesign togehter with autocalc ?*) +datatype auto = + Step of int (*1 do #int steps; may stop in model/specify: + IS VERY INEFFICIENT IN MODEL/SPECIY*) +| CompleteModel (*2 complete modeling + if model complete, finish specifying + start solving*) +| CompleteCalcHead (*3 complete model/specify in one go + start solving*) +| CompleteToSubpbl (*4 stop at the next begin of a subproblem, + if none, complete the actual (sub)problem*) +| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*) +| CompleteCalc; (*6 complete the calculation as a whole*) +fun autoord (Step _ ) = 1 + | autoord CompleteModel = 2 + | autoord CompleteCalcHead = 3 + | autoord CompleteToSubpbl = 4 + | autoord CompleteSubpbl = 5 + | autoord CompleteCalc = 6; + +(* val (auto, c, (ptp as (_, p))) = (auto, (c@c'), ptp); + *) +fun complete_solve auto c (ptp as (_, p): ptree * pos') = + if p = ([], Res) then ("end-of-calculation", [], ptp) else + case nxt_solve_ ptp of + ((Subproblem _, tac_, (_, is))::_, c', ptp') => +(* val ptp' = ptp'''; + *) + if autoord auto < 5 then ("ok", c@c', ptp) + else let val ptp = all_modspec ptp'; + val (_, c'', ptp) = all_solve auto (c@c') ptp; + in complete_solve auto (c@c'@c'') ptp end + | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) => + if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp') + else complete_solve auto (c@c') ptp' + | ((End_Detail, _, _)::_, c', ptp') => + if autoord auto < 6 then ("ok", c@c', ptp') + else complete_solve auto (c@c') ptp' + | (_, c', ptp') => complete_solve auto (c@c') ptp' +(* val (tacis, c', ptp') = nxt_solve_ ptp; + val (tacis, c', ptp'') = nxt_solve_ ptp'; + val (tacis, c', ptp''') = nxt_solve_ ptp''; + val (tacis, c', ptp'''') = nxt_solve_ ptp'''; + val (tacis, c', ptp''''') = nxt_solve_ ptp''''; + *) +and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') = +(* val (ptp as (pt, (p,_))) = ptp; + val (ptp as (pt, (p,_))) = ptp'; + val (ptp as (pt, (p,_))) = (pt, pos); + *) + let val (_,_,mI) = get_obj g_spec pt p; + val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate)) + e_istate ptp; + in complete_solve auto (c@c') ptp end; +(*@@@ vvv @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) +fun complete_solve auto c (ptp as (_, p as (_,p_)): ptree * pos') = + if p = ([], Res) then ("end-of-calculation", [], ptp) else + if member op = [Pbl,Met] p_ + then let val ptp = all_modspec ptp + val (_, c', ptp) = all_solve auto c ptp + in complete_solve auto (c@c') ptp end + else case nxt_solve_ ptp of + ((Subproblem _, tac_, (_, is))::_, c', ptp') => + if autoord auto < 5 then ("ok", c@c', ptp) + else let val ptp = all_modspec ptp' + val (_, c'', ptp) = all_solve auto (c@c') ptp + in complete_solve auto (c@c'@c'') ptp end + | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) => + if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp') + else complete_solve auto (c@c') ptp' + | ((End_Detail, _, _)::_, c', ptp') => + if autoord auto < 6 then ("ok", c@c', ptp') + else complete_solve auto (c@c') ptp' + | (_, c', ptp') => complete_solve auto (c@c') ptp' +and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') = + let val (_,_,mI) = get_obj g_spec pt p + val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate)) + e_istate ptp + in complete_solve auto (c@c') ptp end; + +(*.aux.fun for detailrls with Rrls, reverse rewriting.*) +(* val (nds, t, ((rule, (t', asm)) :: rts)) = ([], t, rul_terms); + *) +fun rul_terms_2nds nds t [] = nds + | rul_terms_2nds nds t ((rule, res as (t', _)) :: rts) = + (append_atomic [] e_istate t (rule2tac [] rule) res Complete EmptyPtree) :: + (rul_terms_2nds nds t' rts); + + +(*. detail steps done internally by Rewrite_Set* + into ctree by use of a script .*) +(* val (pt, (p,p_)) = (pt, pos); + *) +fun detailrls pt ((p,p_):pos') = + let val t = get_obj g_form pt p + val tac = get_obj g_tac pt p + val rls = (assoc_rls o rls_of) tac + in case rls of +(* val Rrls {scr = Rfuns {init_state,...},...} = rls; + *) + Rrls {scr = Rfuns {init_state,...},...} => + let val (_,_,_,rul_terms) = init_state t + val newnds = rul_terms_2nds [] t rul_terms + val pt''' = ins_chn newnds pt p + in ("detailrls", pt''', (p @ [length newnds], Res):pos') end + | _ => + let val is = init_istate tac t + (*TODO.WN060602 ScrState (["(t_, Problem (Isac,[equation,univar]))"] + is wrong for simpl, but working ?!? *) + val tac_ = Apply_Method' (e_metID(*WN0402: see generate1 !?!*), + SOME t, is) + val pos' = ((lev_on o lev_dn) p, Frm) + val thy = assoc_thy "Isac.thy" + val (_,_,_,pt') = (*implicit Take*)generate1 thy tac_ is pos' pt + val (_,_,(pt'',_)) = complete_solve CompleteSubpbl [] (pt',pos') + val newnds = children (get_nd pt'' p) + val pt''' = ins_chn newnds pt p + (*complete_solve cuts branches after*) + in ("detailrls", pt'''(*, get_formress [] ((lev_on o lev_dn) p)cn*), + (p @ [length newnds], Res):pos') end + end; + + + +(* val(mI,m)=m;val ppp=p;(*!!!*)val(p,p_)=pos;val(_,pt,_)=ppp(*!!!*); + get_form ((mI,m):tac'_) ((p,p_):pos') ppp; + *) +fun get_form ((mI,m):tac'_) ((p,p_):pos') pt = + case applicable_in (p,p_) pt m of + Notappl e => Error' (Error_ e) + | Appl m => + (* val Appl m=applicable_in (p,p_) pt m; + *) + if member op = specsteps mI + then let val (_,_,f,_,_,_) = specify m (p,p_) [] pt + in f end + else let val (*_,_,f,_,_,_*)_ = solve (mI,m) (pt,(p,p_)) + in (*f*) EmptyMout end; + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/AlgEin.ML --- a/src/Tools/isac/IsacKnowledge/AlgEin.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,141 +0,0 @@ -(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt - author: Walther Neuper 2007 - (c) due to copyright terms - -use"IsacKnowledge/AlgEin.ML"; -use"AlgEin.ML"; - -remove_thy"Typefix"; -remove_thy"AlgEin"; -use_thy"IsacKnowledge/Isac"; -*) - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("AlgEin.thy",AlgEin.thy)]); - -(** problems **) - -store_pbt - (prep_pbt AlgEin.thy "pbl_algein" [] e_pblID - (["Berechnung"], [], e_rls, NONE, - [])); -(* WN070405 -store_pbt - (prep_pbt AlgEin.thy "pbl_algein_num" [] e_pblID - (["numerische", "Berechnung"], - [("#Given" ,["KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]), - ("#Find" ,["GesamtLaenge l_"]) - ], - append_rls "e_rls" e_rls [], - NONE, - [])); -*) -store_pbt - (prep_pbt AlgEin.thy "pbl_algein_numsym" [] e_pblID - (["numerischSymbolische", "Berechnung"], - [("#Given" ,["KantenLaenge k_","Querschnitt q__"(*q_ in Biegelinie.thy*), - "KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]), - ("#Find" ,["GesamtLaenge l_"]) - ], - e_rls, - NONE, - [["Berechnung","erstNumerisch"],["Berechnung","erstSymbolisch"]])); - -(* show_ptyps(); - *) - - -(** methods **) - -store_met - (prep_met AlgEin.thy "met_algein" [] e_metID - (["Berechnung"], - [], - {rew_ord'="tless_true", rls'= Erls, calc = [], - srls = Erls, prls = Erls, - crls =Erls , nrls = Erls}, -"empty_script" -)); - -store_met - (prep_met AlgEin.thy "met_algein_numsym" [] e_metID - (["Berechnung","erstNumerisch"], - [], - {rew_ord'="tless_true", rls'= Erls, calc = [], - srls = Erls, prls = Erls, - crls =Erls , nrls = Erls}, -"empty_script" -)); - -store_met - (prep_met AlgEin.thy "met_algein_numsym" [] e_metID - (["Berechnung","erstNumerisch"], - [("#Given" ,["KantenLaenge k_","Querschnitt q__", - "KantenUnten u_", "KantenSenkrecht s_", - "KantenOben o_"]), - ("#Find" ,["GesamtLaenge l_"]) - ], - {rew_ord'="tless_true", rls'= e_rls, calc = [], - srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls - [Calc ("Atools.boollist2sum", - eval_boollist2sum "")], - prls = e_rls, crls =e_rls , nrls = norm_Rational}, -"Script RechnenSymbolScript (k_::bool) (q__::bool) \ -\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\ -\ (let t_ = Take (l_ = oben + senkrecht + unten); \ -\ sum_ = boollist2sum o_;\ -\ t_ = Substitute [oben = sum_] t_;\ -\ t_ = Substitute o_ t_;\ -\ t_ = Substitute [k_, q__] t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ -\ sum_ = boollist2sum s_;\ -\ t_ = Substitute [senkrecht = sum_] t_;\ -\ t_ = Substitute s_ t_;\ -\ t_ = Substitute [k_, q__] t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ -\ sum_ = boollist2sum u_;\ -\ t_ = Substitute [unten = sum_] t_;\ -\ t_ = Substitute u_ t_;\ -\ t_ = Substitute [k_, q__] t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_\ -\ in (Try (Rewrite_Set norm_Poly False)) t_)" -)); - -store_met - (prep_met AlgEin.thy "met_algein_symnum" [] e_metID - (["Berechnung","erstSymbolisch"], - [("#Given" ,["KantenLaenge k_","Querschnitt q__", - "KantenUnten u_", "KantenSenkrecht s_", - "KantenOben o_"]), - ("#Find" ,["GesamtLaenge l_"]) - ], - {rew_ord'="tless_true", rls'= e_rls, calc = [], - srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls - [Calc ("Atools.boollist2sum", - eval_boollist2sum "")], - prls = e_rls, - crls =e_rls , nrls = norm_Rational}, -"Script RechnenSymbolScript (k_::bool) (q__::bool) \ -\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\ -\ (let t_ = Take (l_ = oben + senkrecht + unten); \ -\ sum_ = boollist2sum o_;\ -\ t_ = Substitute [oben = sum_] t_;\ -\ t_ = Substitute o_ t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ -\ sum_ = boollist2sum s_;\ -\ t_ = Substitute [senkrecht = sum_] t_;\ -\ t_ = Substitute s_ t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ -\ sum_ = boollist2sum u_;\ -\ t_ = Substitute [unten = sum_] t_;\ -\ t_ = Substitute u_ t_;\ -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ -\ t_ = Substitute [k_, q__] t_\ -\ in (Try (Rewrite_Set norm_Poly False)) t_)" -)); - -(* show_mets(); - *) -(* use"IsacKnowledge/AlgEin.ML"; - *) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/AlgEin.thy --- a/src/Tools/isac/IsacKnowledge/AlgEin.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt - author: Walther Neuper 2007 - (c) due to copyright terms - -remove_thy"AlgEin"; -use_thy"IsacKnowledge/AlgEin"; -use_thy_only"IsacKnowledge/AlgEin"; - -remove_thy"AlgEin"; -use_thy"IsacKnowledge/Isac"; -*) - -AlgEin = Rational + -(*Poly + ..shouldbe sufficient, but norm_Poly *) - -consts - - (*new Descriptions in the related problems*) - KantenUnten :: bool list => una - KantenSenkrecht :: bool list => una - KantenOben :: bool list => una - KantenLaenge :: bool => una - Querschnitt :: bool => una - GesamtLaenge :: real => una - - (*Script-names*) - RechnenSymbolScript :: "[bool,bool,bool list,bool list,bool list,real, - bool] => bool" - ("((Script RechnenSymbolScript (_ _ _ _ _ _ =))// (_))" 9) - -(* -rules - (*this axiom creates a contradictory formal system, - see problem TOOODO *) -*) - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Atools.ML --- a/src/Tools/isac/IsacKnowledge/Atools.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,645 +0,0 @@ -(* tools for arithmetic - WN.8.3.01 - use"../IsacKnowledge/Atools.ML"; - use"IsacKnowledge/Atools.ML"; - use"Atools.ML"; - *) - -(* -copy from doc/math-eng.tex WN.28.3.03 -WN071228 extended - -\section{Coding standards} - -%WN071228 extended -----vvv -\subsection{Identifiers} -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). - -This are the preliminary rules for naming identifiers> -\begin{description} -\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}. -\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}. -\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~! -\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}. -\item [???] ??? -\item [???] ??? -\end{description} -%WN071228 extended -----^^^ - - -\subsection{Rule sets} -The actual version of the coding standards for rulesets is in {\tt /IsacKnowledge/Atools.ML where it can be viewed using the knowledge browsers. - -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. -\begin{description} - -\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). - -\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. - -\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. -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). - -\end{description} -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. -The following rulesets are used for internal purposes and usually invisible to the (naive) user: -\begin{description} - -\item [*\_erls] -\item [*\_prls] -\item [*\_srls] - -\end{description} -{\tt append_rls, merge_rls, remove_rls} -*) - -"******* Atools.ML begin *******"; -theory' := overwritel (!theory', [("Atools.thy",Atools.thy)]); - -(** evaluation of numerals and special predicates on the meta-level **) -(*-------------------------functions---------------------*) -local (* rlang 09.02 *) - (*.a 'c is coefficient of v' if v does occur in c.*) - fun coeff_in v c = member op = (vars c) v; -in - fun occurs_in v t = coeff_in v t; -end; - -(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*) -fun eval_occurs_in _ "Atools.occurs'_in" - (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ = - ((*writeln("@@@ eval_occurs_in: v= "^(term2str v)); - writeln("@@@ eval_occurs_in: t= "^(term2str t));*) - if occurs_in v t - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const)))) - | eval_occurs_in _ _ _ _ = NONE; - -(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*) -fun some_occur_in vs t = - let fun occurs_in' a b = occurs_in b a - in foldl or_ (false, map (occurs_in' t) vs) end; - -(*("some_occur_in", ("Atools.some'_occur'_in", - eval_some_occur_in "#eval_some_occur_in_"))*) -fun eval_some_occur_in _ "Atools.some'_occur'_in" - (p as (Const ("Atools.some'_occur'_in",_) - $ vs $ t)) _ = - if some_occur_in (isalist2list vs) t - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_some_occur_in _ _ _ _ = NONE; - - - - -(*evaluate 'is_atom'*) -(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*) -fun eval_is_atom (thmid:string) "Atools.is'_atom" - (t as (Const(op0,_) $ arg)) thy = - (case arg of - Free (n,_) => SOME (mk_thmid thmid op0 n "", - Trueprop $ (mk_equality (t, true_as_term))) - | _ => SOME (mk_thmid thmid op0 "" "", - Trueprop $ (mk_equality (t, false_as_term)))) - | eval_is_atom _ _ _ _ = NONE; - -(*evaluate 'is_even'*) -fun even i = (i div 2) * 2 = i; -(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*) -fun eval_is_even (thmid:string) "Atools.is'_even" - (t as (Const(op0,_) $ arg)) thy = - (case arg of - Free (n,_) => - (case int_of_str n of - SOME i => - if even i then SOME (mk_thmid thmid op0 n "", - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 "" "", - Trueprop $ (mk_equality (t, false_as_term))) - | _ => NONE) - | _ => NONE) - | eval_is_even _ _ _ _ = NONE; - -(*evaluate 'is_const'*) -(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*) -fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*) - (t as (Const(op0,t0) $ arg)) (thy:theory) = - (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*) - (case arg of - Const (n1,_) => - SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, false_as_term))) - | Free (n1,_) => - if is_numeral n1 - then SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, false_as_term))) - | Const ("Float.Float",_) => - SOME (mk_thmid thmid op0 (term2str arg) "", - Trueprop $ (mk_equality (t, true_as_term))) - | _ => (*NONE*) - SOME (mk_thmid thmid op0 (term2str arg) "", - Trueprop $ (mk_equality (t, false_as_term)))) - | eval_const _ _ _ _ = NONE; - -(*. evaluate binary, associative, commutative operators: *,+,^ .*) -(*("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*) - -(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) = - ("xxxxxx",op_,t,thy); - *) -fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) = - thmid ^ "Float ((" ^ - (string_of_int v11)^","^(string_of_int v12)^"), ("^ - (string_of_int p11)^","^(string_of_int p12)^")) __ (("^ - (string_of_int v21)^","^(string_of_int v22)^"), ("^ - (string_of_int p21)^","^(string_of_int p22)^"))"; - -(*.convert int and float to internal floatingpoint prepresentation.*) -fun numeral (Free (str, T)) = - (case int_of_str str of - SOME i => SOME ((i, 0), (0, 0)) - | NONE => NONE) - | numeral (Const ("Float.Float", _) $ - (Const ("Pair", _) $ - (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $ - (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))= - (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of - (SOME v1', SOME v2', SOME p1', SOME p2') => - SOME ((v1', v2'), (p1', p2')) - | _ => NONE) - | numeral _ = NONE; - -(*.evaluate binary associative operations.*) -fun eval_binop (thmid:string) (op_:string) - (t as ( Const(op0,t0) $ - (Const(op0',t0') $ v $ t1) $ t2)) - thy = (*binary . (v.n1).n2*) - if op0 = op0' then - case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - let val (T1,T2,Trange) = dest_binop_typ t0 - val res = calc (if op0 = "op -" then "op +" else op0) n1 n2 - (*WN071229 "HOL.divide" never tried*) - val rhs = var_op_float v op_ t0 T1 res - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE - else NONE - | eval_binop (thmid:string) (op_:string) - (t as - (Const (op0, t0) $ t1 $ - (Const (op0', t0') $ t2 $ v))) - thy = (*binary . n1.(n2.v)*) - if op0 = op0' then - case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - if op0 = "op -" then NONE else - let val (T1,T2,Trange) = dest_binop_typ t0 - val res = calc op0 n1 n2 - val rhs = float_op_var v op_ t0 T1 res - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE - else NONE - - | eval_binop (thmid:string) (op_:string) - (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*) - (case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - let val (T1,T2,Trange) = dest_binop_typ t0; - val res = calc op0 n1 n2; - val rhs = term_of_float Trange res; - val prop = Trueprop $ (mk_equality (t, rhs)); - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE) - | eval_binop _ _ _ _ = NONE; -(* -> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy; -> term2str t; -val it = "-1 + 2 = 1" -> val t = str2term "-1 * (-1 * a)"; -> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy; -> term2str t; -val it = "-1 * (-1 * a) = 1 * a"*) - - - -(*.evaluate < and <= for numerals.*) -(*("le" ,("op <" ,eval_equ "#less_")), - ("leq" ,("op <=" ,eval_equ "#less_equal_"))*) -fun eval_equ (thmid:string) (op_:string) (t as - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = - (case (int_of_str n1, int_of_str n2) of - (SOME n1', SOME n2') => - if calc_equ (strip_thy op0) (n1', n2') - then SOME (mk_thmid thmid op0 n1 n2, - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 n1 n2, - Trueprop $ (mk_equality (t, false_as_term))) - | _ => NONE) - - | eval_equ _ _ _ _ = NONE; - - -(*evaluate identity -> reflI; -val it = "(?t = ?t) = True" -> val t = str2term "x = 0"; -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; - -> val t = str2term "1 = 0"; -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; ------------ thus needs Calc ! -> val t = str2term "0 = 0"; -> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t; -> term2str t'; -val it = "True" - -val t = str2term "Not (x = 0)"; -atomt t; term2str t; -*** ------------- -*** Const ( Not) -*** . Const ( op =) -*** . . Free ( x, ) -*** . . Free ( 0, ) -val it = "x ~= 0" : string*) - -(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of - the arguments: thus special handling by 'fun eval_binop'*) -(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*) -fun eval_ident (thmid:string) "Atools.ident" (t as - (Const (op0,t0) $ t1 $ t2 )) thy = - if t1 = t2 - then SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, false_as_term))) - | eval_ident _ _ _ _ = NONE; -(* TODO -> val t = str2term "x =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(x)_(0)" : string -val it = "(x =!= 0) = False" : string -> val t = str2term "1 =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(1)_(0)" : string -val it = "(1 =!= 0) = False" : string -> val t = str2term "0 =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(0)_(0)" : string -val it = "(0 =!= 0) = True" : string -*) - -(*.evaluate identity of terms, which stay ready for evaluation in turn; - thus returns False only for atoms.*) -(*("equal" ,("op =",eval_equal "#equal_")):calc*) -fun eval_equal (thmid:string) "op =" (t as - (Const (op0,t0) $ t1 $ t2 )) thy = - if t1 = t2 - then ((*writeln"... eval_equal: t1 = t2 --> True";*) - SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, true_as_term))) - ) - else (case (is_atom t1, is_atom t2) of - (true, true) => - ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*) - SOME (mk_thmid thmid op0 - ("("^(term2str t1)^")") ("("^(term2str t2)^")"), - Trueprop $ (mk_equality (t, false_as_term))) - ) - | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*) - NONE)) - | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit"; - NONE); -(* -val t = str2term "x ~= 0"; -val NONE = eval_equal "equal_" "b" t thy; - - -> val t = str2term "(x + 1) = (x + 1)"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(x + 1)_(x + 1)" : string -val it = "(x + 1 = x + 1) = True" : string -> val t = str2term "x = 0"; -> val NONE = eval_equal "equal_" "b" t thy; - -> val t = str2term "1 = 0"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(1)_(0)" : string -val it = "(1 = 0) = False" : string -> val t = str2term "0 = 0"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(0)_(0)" : string -val it = "(0 = 0) = True" : string -*) - - -(** evaluation on the metalevel **) - -(*. evaluate HOL.divide .*) -(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*) -fun eval_cancel (thmid:string) "HOL.divide" (t as - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = - (case (int_of_str n1, int_of_str n2) of - (SOME n1', SOME n2') => - let - val sg = sign2 n1' n2'; - val (T1,T2,Trange) = dest_binop_typ t0; - val gcd' = gcd (abs n1') (abs n2'); - in if gcd' = abs n2' - then let val rhs = term_of_num Trange (sg * (abs n1') div gcd') - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid thmid op0 n1 n2, prop) end - else if 0 < n2' andalso gcd' = 1 then NONE - else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd') - ((abs n2') div gcd') - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid thmid op0 n1 n2, prop) end - end - | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE)) - - | eval_cancel _ _ _ _ = NONE; - -(*. get the argument from a function-definition.*) -(*("argument_in" ,("Atools.argument'_in", - eval_argument_in "Atools.argument'_in"))*) -fun eval_argument_in _ "Atools.argument'_in" - (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ = - if is_Free arg (*could be something to be simplified before*) - then SOME (term2str t ^ " = " ^ term2str arg, - Trueprop $ (mk_equality (t, arg))) - else NONE - | eval_argument_in _ _ _ _ = NONE; - -(*.check if the function-identifier of the first argument matches - the function-identifier of the lhs of the second argument.*) -(*("sameFunId" ,("Atools.sameFunId", - eval_same_funid "Atools.sameFunId"))*) -fun eval_sameFunId _ "Atools.sameFunId" - (p as Const ("Atools.sameFunId",_) $ - (f1 $ _) $ - (Const ("op =", _) $ (f2 $ _) $ _)) _ = - if f1 = f2 - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) -| eval_sameFunId _ _ _ _ = NONE; - - -(*.from a list of fun-definitions "f x = ..." as 2nd argument - filter the elements with the same fun-identfier in "f y" - as the fst argument; - this is, because Isabelles filter takes more than 1 sec.*) -fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2 - | same_funid f1 t = raise error ("same_funid called with t = (" - ^term2str f1^") ("^term2str t^")"); -(*("filter_sameFunId" ,("Atools.filter'_sameFunId", - eval_filter_sameFunId "Atools.filter'_sameFunId"))*) -fun eval_filter_sameFunId _ "Atools.filter'_sameFunId" - (p as Const ("Atools.filter'_sameFunId",_) $ - (fid $ _) $ fs) _ = - let val fs' = ((list2isalist HOLogic.boolT) o - (filter (same_funid fid))) (isalist2list fs) - in SOME (term2str (mk_equality (p, fs')), - Trueprop $ (mk_equality (p, fs'))) end -| eval_filter_sameFunId _ _ _ _ = NONE; - - -(*make a list of terms to a sum*) -fun list2sum [] = error ("list2sum called with []") - | list2sum [s] = s - | list2sum (s::ss) = - let fun sum su [s'] = - Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ su $ s' - | sum su (s'::ss') = - sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ su $ s') ss' - in sum s ss end; - -(*make a list of equalities to the sum of the lhs*) -(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*) -fun eval_boollist2sum _ "Atools.boollist2sum" - (p as Const ("Atools.boollist2sum", _) $ - (l as Const ("List.list.Cons", _) $ _ $ _)) _ = - let val isal = isalist2list l - val lhss = map lhs isal - val sum = list2sum lhss - in SOME ((term2str p) ^ " = " ^ (term2str sum), - Trueprop $ (mk_equality (p, sum))) - end -| eval_boollist2sum _ _ _ _ = NONE; - - - -local - -open Term; - -in -fun termlessI (_:subst) uv = termless uv; -fun term_ordI (_:subst) uv = term_ord uv; -end; - - -(** rule set, for evaluating list-expressions in scripts 8.01.02 **) - - -val list_rls = - append_rls "list_rls" list_rls - [Calc ("op *",eval_binop "#mult_"), - Calc ("op +", eval_binop "#add_"), - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*) - - Calc ("Tools.Vars",eval_var "#Vars_"), - - Thm ("if_True",num_str if_True), - Thm ("if_False",num_str if_False) - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("list_rls",list_rls) - ]); - -(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*) -val tless_true = dummy_ord; -rew_ord' := overwritel (!rew_ord', - [("tless_true", tless_true), - ("e_rew_ord'", tless_true), - ("dummy_ord", dummy_ord)]); - -val calculate_Atools = - append_rls "calculate_Atools" e_rls - [Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - Calc ("op =",eval_equal "#equal_"), - - Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_") - ]; - -val Atools_erls = - append_rls "Atools_erls" e_rls - [Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - (*"(~ True) = False"*) - Thm ("not_false",num_str not_false), - (*"(~ False) = True"*) - Thm ("and_true",and_true), - (*"(?a & True) = ?a"*) - Thm ("and_false",and_false), - (*"(?a & False) = False"*) - Thm ("or_true",or_true), - (*"(?a | True) = True"*) - Thm ("or_false",or_false), - (*"(?a | False) = ?a"*) - - Thm ("rat_leq1",rat_leq1), - Thm ("rat_leq2",rat_leq2), - Thm ("rat_leq3",rat_leq3), - Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ]; - -val Atools_crls = - append_rls "Atools_crls" e_rls - [Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - - Thm ("rat_leq1",rat_leq1), - Thm ("rat_leq2",rat_leq2), - Thm ("rat_leq3",rat_leq3), - Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ]; - -(*val atools_erls = ... waere zu testen ... - merge_rls calculate_Atools - (append_rls Atools_erls (*i.A. zu viele rules*) - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in", - eval_occurs_in "#occurs_in"), - Calc ("Tools.matches",eval_matches "#matches") - ] (*i.A. zu viele rules*) - );*) -(* val atools_erls = prep_rls( - Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - Thm ("and_commute",num_str and_commute), - Thm ("or_commute",num_str or_commute), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -ruleset' := overwritelth thy - (!ruleset', - [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*) - ]); -*) -"******* Atools.ML end *******"; - -calclist':= overwritel (!calclist', - [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")), - ("some_occur_in", - ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")), - ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")), - ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")), - ("is_const" ,("Atools.is'_const",eval_const "#is_const_")), - ("le" ,("op <" ,eval_equ "#less_")), - ("leq" ,("op <=" ,eval_equ "#less_equal_")), - ("ident" ,("Atools.ident",eval_ident "#ident_")), - ("equal" ,("op =",eval_equal "#equal_")), - ("PLUS" ,("op +" ,eval_binop "#add_")), - ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls - no script with "minus"*) - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_")), - ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum "")) - ]); - -val list_rls = prep_rls( - merge_rls "list_erls" - (Rls {id="replaced",preconds = [], - rew_ord = ("termlessI", termlessI), - erls = Rls {id="list_elrs", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = e_rls, - srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Calc ("op +", eval_binop "#add_"), - Calc ("op <",eval_equ "#less_") - (* ~~~~~~ for nth_Cons_*) - ], - scr = EmptyScr}, - srls = Erls, calc = [], (*asm_thm = [], *) - rules = [], scr = EmptyScr}) - list_rls); -ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Atools.thy --- a/src/Tools/isac/IsacKnowledge/Atools.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,711 +0,0 @@ -(* Title: tools for arithmetic - Author: Walther Neuper 010308 - (c) due to copyright terms - -remove_thy"Atools"; -use_thy"IsacKnowledge/Atools"; -use_thy"IsacKnowledge/Isac"; - -use_thy_only"IsacKnowledge/Atools"; -use_thy"IsacKnowledge/Isac"; -*) - -theory Atools imports Descript Typefix begin - -consts - - Arbfix :: "real" - Undef :: "real" - dummy :: "real" - - some'_occur'_in :: "[real list, 'a] => bool" ("some'_of _ occur'_in _") - occurs'_in :: "[real , 'a] => bool" ("_ occurs'_in _") - - pow :: "[real, real] => real" (infixr "^^^" 80) -(* ~~~ power doesn't allow Free("2",real) ^ Free("2",nat) - ~~~~ ~~~~ ~~~~ ~~~*) -(*WN0603 at FE-interface encoded strings to '^', - see 'fun encode', fun 'decode'*) - - abs :: "real => real" ("(|| _ ||)") -(* ~~~ FIXXXME Isabelle2002 has abs already !!!*) - absset :: "real set => real" ("(||| _ |||)") - (*is numeral constant ?*) - is'_const :: "real => bool" ("_ is'_const" 10) - (*is_const rename to is_num FIXXXME.WN.16.5.03 *) - is'_atom :: "real => bool" ("_ is'_atom" 10) - is'_even :: "real => bool" ("_ is'_even" 10) - - (* identity on term level*) - ident :: "['a, 'a] => bool" ("(_ =!=/ _)" [51, 51] 50) - - argument'_in :: "real => real" ("argument'_in _" 10) - sameFunId :: "[real, bool] => bool" (**"same'_funid _ _" 10 - WN0609 changed the id, because ".. _ _" inhibits currying**) - filter'_sameFunId:: "[real, bool list] => bool list" - ("filter'_sameFunId _ _" 10) - boollist2sum :: "bool list => real" - -axioms (*for evaluating the assumptions of conditional rules*) - - last_thmI "lastI (x#xs) = (if xs =!= [] then x else lastI xs)" - real_unari_minus "- a = (-1) * a" (*Isa!*) - - rle_refl "(n::real) <= n" -(*reflI "(t = t) = True"*) - radd_left_cancel_le "((k::real) + m <= k + n) = (m <= n)" - not_true "(~ True) = False" - not_false "(~ False) = True" - and_true "(a & True) = a" - and_false "(a & False) = False" - or_true "(a | True) = True" - or_false "(a | False) = a" - and_commute "(a & b) = (b & a)" - or_commute "(a | b) = (b | a)" - - (*.should be in Rational.thy, but: - needed for asms in e.g. d2_pqformula1 in PolyEq.ML, RootEq.ML.*) - rat_leq1 "[| b ~= 0; d ~= 0 |] ==> \ - \((a / b) <= (c / d)) = ((a*d) <= (b*c))"(*Isa?*) - rat_leq2 "d ~= 0 ==> \ - \( a <= (c / d)) = ((a*d) <= c )"(*Isa?*) - rat_leq3 "b ~= 0 ==> \ - \((a / b) <= c ) = ( a <= (b*c))"(*Isa?*) - -text {*copy from doc/math-eng.tex WN.28.3.03 -WN071228 extended *} - - -section {*Coding standards*} -subsection {*Identifiers*} -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). - -This are the preliminary rules for naming identifiers> -\begin{description} -\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}. -\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}. -\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~! -\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}. -\item [???] ??? -\item [???] ??? -\end{description} -%WN071228 extended *} - -subsection {*Rule sets*} -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. - -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. -\begin{description} - -\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). - -\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. - -\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. -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). -\end{description} - -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. -The following rulesets are used for internal purposes and usually invisible to the (naive) user: -\begin{description} - -\item [*\_erls] -\item [*\_prls] -\item [*\_srls] - -\end{description} -{\tt append_rls, merge_rls, remove_rls} -*} - -ML {* - -(** evaluation of numerals and special predicates on the meta-level **) -(*-------------------------functions---------------------*) -local (* rlang 09.02 *) - (*.a 'c is coefficient of v' if v does occur in c.*) - fun coeff_in v c = member op = (vars c) v; -in - fun occurs_in v t = coeff_in v t; -end; - -(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*) -fun eval_occurs_in _ "Atools.occurs'_in" - (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ = - ((*writeln("@@@ eval_occurs_in: v= "^(term2str v)); - writeln("@@@ eval_occurs_in: t= "^(term2str t));*) - if occurs_in v t - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const)))) - | eval_occurs_in _ _ _ _ = NONE; - -(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*) -fun some_occur_in vs t = - let fun occurs_in' a b = occurs_in b a - in foldl or_ (false, map (occurs_in' t) vs) end; - -(*("some_occur_in", ("Atools.some'_occur'_in", - eval_some_occur_in "#eval_some_occur_in_"))*) -fun eval_some_occur_in _ "Atools.some'_occur'_in" - (p as (Const ("Atools.some'_occur'_in",_) - $ vs $ t)) _ = - if some_occur_in (isalist2list vs) t - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_some_occur_in _ _ _ _ = NONE; - - - - -(*evaluate 'is_atom'*) -(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*) -fun eval_is_atom (thmid:string) "Atools.is'_atom" - (t as (Const(op0,_) $ arg)) thy = - (case arg of - Free (n,_) => SOME (mk_thmid thmid op0 n "", - Trueprop $ (mk_equality (t, true_as_term))) - | _ => SOME (mk_thmid thmid op0 "" "", - Trueprop $ (mk_equality (t, false_as_term)))) - | eval_is_atom _ _ _ _ = NONE; - -(*evaluate 'is_even'*) -fun even i = (i div 2) * 2 = i; -(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*) -fun eval_is_even (thmid:string) "Atools.is'_even" - (t as (Const(op0,_) $ arg)) thy = - (case arg of - Free (n,_) => - (case int_of_str n of - SOME i => - if even i then SOME (mk_thmid thmid op0 n "", - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 "" "", - Trueprop $ (mk_equality (t, false_as_term))) - | _ => NONE) - | _ => NONE) - | eval_is_even _ _ _ _ = NONE; - -(*evaluate 'is_const'*) -(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*) -fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*) - (t as (Const(op0,t0) $ arg)) (thy:theory) = - (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*) - (case arg of - Const (n1,_) => - SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, false_as_term))) - | Free (n1,_) => - if is_numeral n1 - then SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 n1 "", - Trueprop $ (mk_equality (t, false_as_term))) - | Const ("Float.Float",_) => - SOME (mk_thmid thmid op0 (term2str arg) "", - Trueprop $ (mk_equality (t, true_as_term))) - | _ => (*NONE*) - SOME (mk_thmid thmid op0 (term2str arg) "", - Trueprop $ (mk_equality (t, false_as_term)))) - | eval_const _ _ _ _ = NONE; - -(*. evaluate binary, associative, commutative operators: *,+,^ .*) -(*("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*) - -(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) = - ("xxxxxx",op_,t,thy); - *) -fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) = - thmid ^ "Float ((" ^ - (string_of_int v11)^","^(string_of_int v12)^"), ("^ - (string_of_int p11)^","^(string_of_int p12)^")) __ (("^ - (string_of_int v21)^","^(string_of_int v22)^"), ("^ - (string_of_int p21)^","^(string_of_int p22)^"))"; - -(*.convert int and float to internal floatingpoint prepresentation.*) -fun numeral (Free (str, T)) = - (case int_of_str str of - SOME i => SOME ((i, 0), (0, 0)) - | NONE => NONE) - | numeral (Const ("Float.Float", _) $ - (Const ("Pair", _) $ - (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $ - (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))= - (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of - (SOME v1', SOME v2', SOME p1', SOME p2') => - SOME ((v1', v2'), (p1', p2')) - | _ => NONE) - | numeral _ = NONE; - -(*.evaluate binary associative operations.*) -fun eval_binop (thmid:string) (op_:string) - (t as ( Const(op0,t0) $ - (Const(op0',t0') $ v $ t1) $ t2)) - thy = (*binary . (v.n1).n2*) - if op0 = op0' then - case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - let val (T1,T2,Trange) = dest_binop_typ t0 - val res = calc (if op0 = "op -" then "op +" else op0) n1 n2 - (*WN071229 "HOL.divide" never tried*) - val rhs = var_op_float v op_ t0 T1 res - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE - else NONE - | eval_binop (thmid:string) (op_:string) - (t as - (Const (op0, t0) $ t1 $ - (Const (op0', t0') $ t2 $ v))) - thy = (*binary . n1.(n2.v)*) - if op0 = op0' then - case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - if op0 = "op -" then NONE else - let val (T1,T2,Trange) = dest_binop_typ t0 - val res = calc op0 n1 n2 - val rhs = float_op_var v op_ t0 T1 res - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE - else NONE - - | eval_binop (thmid:string) (op_:string) - (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*) - (case (numeral t1, numeral t2) of - (SOME n1, SOME n2) => - let val (T1,T2,Trange) = dest_binop_typ t0; - val res = calc op0 n1 n2; - val rhs = term_of_float Trange res; - val prop = Trueprop $ (mk_equality (t, rhs)); - in SOME (mk_thmid_f thmid n1 n2, prop) end - | _ => NONE) - | eval_binop _ _ _ _ = NONE; -(* -> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy; -> term2str t; -val it = "-1 + 2 = 1" -> val t = str2term "-1 * (-1 * a)"; -> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy; -> term2str t; -val it = "-1 * (-1 * a) = 1 * a"*) - - - -(*.evaluate < and <= for numerals.*) -(*("le" ,("op <" ,eval_equ "#less_")), - ("leq" ,("op <=" ,eval_equ "#less_equal_"))*) -fun eval_equ (thmid:string) (op_:string) (t as - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = - (case (int_of_str n1, int_of_str n2) of - (SOME n1', SOME n2') => - if calc_equ (strip_thy op0) (n1', n2') - then SOME (mk_thmid thmid op0 n1 n2, - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 n1 n2, - Trueprop $ (mk_equality (t, false_as_term))) - | _ => NONE) - - | eval_equ _ _ _ _ = NONE; - - -(*evaluate identity -> reflI; -val it = "(?t = ?t) = True" -> val t = str2term "x = 0"; -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; - -> val t = str2term "1 = 0"; -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; ------------ thus needs Calc ! -> val t = str2term "0 = 0"; -> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t; -> term2str t'; -val it = "True" - -val t = str2term "Not (x = 0)"; -atomt t; term2str t; -*** ------------- -*** Const ( Not) -*** . Const ( op =) -*** . . Free ( x, ) -*** . . Free ( 0, ) -val it = "x ~= 0" : string*) - -(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of - the arguments: thus special handling by 'fun eval_binop'*) -(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*) -fun eval_ident (thmid:string) "Atools.ident" (t as - (Const (op0,t0) $ t1 $ t2 )) thy = - if t1 = t2 - then SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, false_as_term))) - | eval_ident _ _ _ _ = NONE; -(* TODO -> val t = str2term "x =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(x)_(0)" : string -val it = "(x =!= 0) = False" : string -> val t = str2term "1 =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(1)_(0)" : string -val it = "(1 =!= 0) = False" : string -> val t = str2term "0 =!= 0"; -> val SOME (str, t') = eval_ident "ident_" "b" t thy; -> term2str t'; -val str = "ident_(0)_(0)" : string -val it = "(0 =!= 0) = True" : string -*) - -(*.evaluate identity of terms, which stay ready for evaluation in turn; - thus returns False only for atoms.*) -(*("equal" ,("op =",eval_equal "#equal_")):calc*) -fun eval_equal (thmid:string) "op =" (t as - (Const (op0,t0) $ t1 $ t2 )) thy = - if t1 = t2 - then ((*writeln"... eval_equal: t1 = t2 --> True";*) - SOME (mk_thmid thmid op0 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), - Trueprop $ (mk_equality (t, true_as_term))) - ) - else (case (is_atom t1, is_atom t2) of - (true, true) => - ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*) - SOME (mk_thmid thmid op0 - ("("^(term2str t1)^")") ("("^(term2str t2)^")"), - Trueprop $ (mk_equality (t, false_as_term))) - ) - | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*) - NONE)) - | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit"; - NONE); -(* -val t = str2term "x ~= 0"; -val NONE = eval_equal "equal_" "b" t thy; - - -> val t = str2term "(x + 1) = (x + 1)"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(x + 1)_(x + 1)" : string -val it = "(x + 1 = x + 1) = True" : string -> val t = str2term "x = 0"; -> val NONE = eval_equal "equal_" "b" t thy; - -> val t = str2term "1 = 0"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(1)_(0)" : string -val it = "(1 = 0) = False" : string -> val t = str2term "0 = 0"; -> val SOME (str, t') = eval_equal "equal_" "b" t thy; -> term2str t'; -val str = "equal_(0)_(0)" : string -val it = "(0 = 0) = True" : string -*) - - -(** evaluation on the metalevel **) - -(*. evaluate HOL.divide .*) -(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*) -fun eval_cancel (thmid:string) "HOL.divide" (t as - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = - (case (int_of_str n1, int_of_str n2) of - (SOME n1', SOME n2') => - let - val sg = sign2 n1' n2'; - val (T1,T2,Trange) = dest_binop_typ t0; - val gcd' = gcd (abs n1') (abs n2'); - in if gcd' = abs n2' - then let val rhs = term_of_num Trange (sg * (abs n1') div gcd') - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid thmid op0 n1 n2, prop) end - else if 0 < n2' andalso gcd' = 1 then NONE - else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd') - ((abs n2') div gcd') - val prop = Trueprop $ (mk_equality (t, rhs)) - in SOME (mk_thmid thmid op0 n1 n2, prop) end - end - | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE)) - - | eval_cancel _ _ _ _ = NONE; - -(*. get the argument from a function-definition.*) -(*("argument_in" ,("Atools.argument'_in", - eval_argument_in "Atools.argument'_in"))*) -fun eval_argument_in _ "Atools.argument'_in" - (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ = - if is_Free arg (*could be something to be simplified before*) - then SOME (term2str t ^ " = " ^ term2str arg, - Trueprop $ (mk_equality (t, arg))) - else NONE - | eval_argument_in _ _ _ _ = NONE; - -(*.check if the function-identifier of the first argument matches - the function-identifier of the lhs of the second argument.*) -(*("sameFunId" ,("Atools.sameFunId", - eval_same_funid "Atools.sameFunId"))*) -fun eval_sameFunId _ "Atools.sameFunId" - (p as Const ("Atools.sameFunId",_) $ - (f1 $ _) $ - (Const ("op =", _) $ (f2 $ _) $ _)) _ = - if f1 = f2 - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) -| eval_sameFunId _ _ _ _ = NONE; - - -(*.from a list of fun-definitions "f x = ..." as 2nd argument - filter the elements with the same fun-identfier in "f y" - as the fst argument; - this is, because Isabelles filter takes more than 1 sec.*) -fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2 - | same_funid f1 t = raise error ("same_funid called with t = (" - ^term2str f1^") ("^term2str t^")"); -(*("filter_sameFunId" ,("Atools.filter'_sameFunId", - eval_filter_sameFunId "Atools.filter'_sameFunId"))*) -fun eval_filter_sameFunId _ "Atools.filter'_sameFunId" - (p as Const ("Atools.filter'_sameFunId",_) $ - (fid $ _) $ fs) _ = - let val fs' = ((list2isalist HOLogic.boolT) o - (filter (same_funid fid))) (isalist2list fs) - in SOME (term2str (mk_equality (p, fs')), - Trueprop $ (mk_equality (p, fs'))) end -| eval_filter_sameFunId _ _ _ _ = NONE; - - -(*make a list of terms to a sum*) -fun list2sum [] = error ("list2sum called with []") - | list2sum [s] = s - | list2sum (s::ss) = - let fun sum su [s'] = - Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ su $ s' - | sum su (s'::ss') = - sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ su $ s') ss' - in sum s ss end; - -(*make a list of equalities to the sum of the lhs*) -(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*) -fun eval_boollist2sum _ "Atools.boollist2sum" - (p as Const ("Atools.boollist2sum", _) $ - (l as Const ("List.list.Cons", _) $ _ $ _)) _ = - let val isal = isalist2list l - val lhss = map lhs isal - val sum = list2sum lhss - in SOME ((term2str p) ^ " = " ^ (term2str sum), - Trueprop $ (mk_equality (p, sum))) - end -| eval_boollist2sum _ _ _ _ = NONE; - - - -local - -open Term; - -in -fun termlessI (_:subst) uv = termless uv; -fun term_ordI (_:subst) uv = term_ord uv; -end; - - -(** rule set, for evaluating list-expressions in scripts 8.01.02 **) - - -val list_rls = - append_rls "list_rls" list_rls - [Calc ("op *",eval_binop "#mult_"), - Calc ("op +", eval_binop "#add_"), - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*) - - Calc ("Tools.Vars",eval_var "#Vars_"), - - Thm ("if_True",num_str if_True), - Thm ("if_False",num_str if_False) - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("list_rls",list_rls) - ]); - -(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*) -val tless_true = dummy_ord; -rew_ord' := overwritel (!rew_ord', - [("tless_true", tless_true), - ("e_rew_ord'", tless_true), - ("dummy_ord", dummy_ord)]); - -val calculate_Atools = - append_rls "calculate_Atools" e_rls - [Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - Calc ("op =",eval_equal "#equal_"), - - Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_") - ]; - -val Atools_erls = - append_rls "Atools_erls" e_rls - [Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - (*"(~ True) = False"*) - Thm ("not_false",num_str not_false), - (*"(~ False) = True"*) - Thm ("and_true",and_true), - (*"(?a & True) = ?a"*) - Thm ("and_false",and_false), - (*"(?a & False) = False"*) - Thm ("or_true",or_true), - (*"(?a | True) = True"*) - Thm ("or_false",or_false), - (*"(?a | False) = ?a"*) - - Thm ("rat_leq1",rat_leq1), - Thm ("rat_leq2",rat_leq2), - Thm ("rat_leq3",rat_leq3), - Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ]; - -val Atools_crls = - append_rls "Atools_crls" e_rls - [Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - - Thm ("rat_leq1",rat_leq1), - Thm ("rat_leq2",rat_leq2), - Thm ("rat_leq3",rat_leq3), - Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ]; - -(*val atools_erls = ... waere zu testen ... - merge_rls calculate_Atools - (append_rls Atools_erls (*i.A. zu viele rules*) - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in", - eval_occurs_in "#occurs_in"), - Calc ("Tools.matches",eval_matches "#matches") - ] (*i.A. zu viele rules*) - );*) -(* val atools_erls = prep_rls( - Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - Thm ("and_commute",num_str and_commute), - Thm ("or_commute",num_str or_commute), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -ruleset' := overwritelth thy - (!ruleset', - [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*) - ]); -*) -"******* Atools.ML end *******"; - -calclist':= overwritel (!calclist', - [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")), - ("some_occur_in", - ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")), - ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")), - ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")), - ("is_const" ,("Atools.is'_const",eval_const "#is_const_")), - ("le" ,("op <" ,eval_equ "#less_")), - ("leq" ,("op <=" ,eval_equ "#less_equal_")), - ("ident" ,("Atools.ident",eval_ident "#ident_")), - ("equal" ,("op =",eval_equal "#equal_")), - ("PLUS" ,("op +" ,eval_binop "#add_")), - ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls - no script with "minus"*) - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_")), - ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum "")) - ]); - -val list_rls = prep_rls( - merge_rls "list_erls" - (Rls {id="replaced",preconds = [], - rew_ord = ("termlessI", termlessI), - erls = Rls {id="list_elrs", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = e_rls, - srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Calc ("op +", eval_binop "#add_"), - Calc ("op <",eval_equ "#less_") - (* ~~~~~~ for nth_Cons_*) - ], - scr = EmptyScr}, - srls = Erls, calc = [], (*asm_thm = [], *) - rules = [], scr = EmptyScr}) - list_rls); -ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]); -*} - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Biegelinie.ML --- a/src/Tools/isac/IsacKnowledge/Biegelinie.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ -(* chapter 'Biegelinie' from the textbook: - Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271. - authors: Walther Neuper 2005 - (c) due to copyright terms - -use"IsacKnowledge/Biegelinie.ML"; -use"Biegelinie.ML"; - -remove_thy"Typefix"; -remove_thy"Biegelinie"; -use_thy"IsacKnowledge/Isac"; -*) - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("Biegelinie.thy",Biegelinie.thy)]); - -(** theory elements **) - -store_isa ["IsacKnowledge"] []; -store_thy Biegelinie.thy - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_isa ["IsacKnowledge", theory2thyID Biegelinie.thy, "Theorems"] - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Belastung_Querkraft", Belastung_Querkraft) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Moment_Neigung", Moment_Neigung) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Moment_Querkraft", Moment_Querkraft) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Neigung_Moment", Neigung_Moment) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Querkraft_Belastung", Querkraft_Belastung) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("Querkraft_Moment", Querkraft_Moment) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; -store_thm Biegelinie.thy ("make_fun_explicit", make_fun_explicit) - ["Walther Neuper 2005 supported by a grant from NMI Austria"]; - - -(** problems **) - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg" [] e_pblID - (["Biegelinien"], - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]), - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) - ("#Find" ,["Biegelinie b_"]), - ("#Relate",["Randbedingungen rb_"]) - ], - append_rls "e_rls" e_rls [], - NONE, - [["IntegrierenUndKonstanteBestimmen2"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_mom" [] e_pblID - (["MomentBestimmte","Biegelinien"], - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]), - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) - ("#Find" ,["Biegelinie b_"]), - ("#Relate",["RandbedingungenBiegung rb_","RandbedingungenMoment rm_"]) - ], - append_rls "e_rls" e_rls [], - NONE, - [["IntegrierenUndKonstanteBestimmen"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_momg" [] e_pblID - (["MomentGegebene","Biegelinien"], - [], - append_rls "e_rls" e_rls [], - NONE, - [["IntegrierenUndKonstanteBestimmen","2xIntegrieren"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_einf" [] e_pblID - (["einfache","Biegelinien"], - [], - append_rls "e_rls" e_rls [], - NONE, - [["IntegrierenUndKonstanteBestimmen","4x4System"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_momquer" [] e_pblID - (["QuerkraftUndMomentBestimmte","Biegelinien"], - [], - append_rls "e_rls" e_rls [], - NONE, - [["IntegrierenUndKonstanteBestimmen","1xIntegrieren"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_vonq" [] e_pblID - (["vonBelastungZu","Biegelinien"], - [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]), - ("#Find" ,["Funktionen funs___"])], - append_rls "e_rls" e_rls [], - NONE, - [["Biegelinien","ausBelastung"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_bieg_randbed" [] e_pblID - (["setzeRandbedingungen","Biegelinien"], - [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]), - ("#Find" ,["Gleichungen equs___"])], - append_rls "e_rls" e_rls [], - NONE, - [["Biegelinien","setzeRandbedingungenEin"]])); - -store_pbt - (prep_pbt Biegelinie.thy "pbl_equ_fromfun" [] e_pblID - (["makeFunctionTo","equation"], - [("#Given" ,["functionEq fun_","substitution sub_"]), - ("#Find" ,["equality equ___"])], - append_rls "e_rls" e_rls [], - NONE, - [["Equation","fromFunction"]])); - - - -(** methods **) - -val srls = Rls {id="srls_IntegrierenUnd..", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls - [(*for asm in nth_Cons_ ...*) - Calc ("op <",eval_equ "#less_"), - (*2nd nth_Cons_ pushes n+-1 into asms*) - Calc("op +", eval_binop "#add_") - ], - srls = Erls, calc = [], - rules = [Thm ("nth_Cons_",num_str nth_Cons_), - Calc("op +", eval_binop "#add_"), - Thm ("nth_Nil_",num_str nth_Nil_), - Calc("Tools.lhs", eval_lhs"eval_lhs_"), - Calc("Tools.rhs", eval_rhs"eval_rhs_"), - Calc("Atools.argument'_in", - eval_argument_in "Atools.argument'_in") - ], - scr = EmptyScr}; - -val srls2 = - Rls {id="srls_IntegrierenUnd..", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls - [(*for asm in nth_Cons_ ...*) - Calc ("op <",eval_equ "#less_"), - (*2nd nth_Cons_ pushes n+-1 into asms*) - Calc("op +", eval_binop "#add_") - ], - srls = Erls, calc = [], - rules = [Thm ("nth_Cons_",num_str nth_Cons_), - Calc("op +", eval_binop "#add_"), - Thm ("nth_Nil_", num_str nth_Nil_), - Calc("Tools.lhs", eval_lhs "eval_lhs_"), - Calc("Atools.filter'_sameFunId", - eval_filter_sameFunId "Atools.filter'_sameFunId"), - (*WN070514 just for smltest/../biegelinie.sml ...*) - Calc("Atools.sameFunId", eval_sameFunId "Atools.sameFunId"), - Thm ("filter_Cons", num_str filter_Cons), - Thm ("filter_Nil", num_str filter_Nil), - Thm ("if_True", num_str if_True), - Thm ("if_False", num_str if_False), - Thm ("hd_thm", num_str hd_thm) - ], - scr = EmptyScr}; -(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) -(* use"IsacKnowledge/Biegelinie.ML"; - *) - -store_met - (prep_met Biegelinie.thy "met_biege" [] e_metID - (["IntegrierenUndKonstanteBestimmen"], - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__", - "FunktionsVariable v_"]), - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) - ("#Find" ,["Biegelinie b_"]), - ("#Relate",["RandbedingungenBiegung rb_", - "RandbedingungenMoment rm_"]) - ], - {rew_ord'="tless_true", - rls' = append_rls "erls_IntegrierenUndK.." e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false)], - calc = [], srls = srls, prls = Erls, - crls = Atools_erls, nrls = Erls}, -"Script BiegelinieScript \ -\(l_::real) (q__::real) (v_::real) (b_::real=>real) \ -\(rb_::bool list) (rm_::bool list) = \ -\ (let q___ = Take (q_ v_ = q__); \ -\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \ -\ (Rewrite Belastung_Querkraft True)) q___; \ -\ (Q__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs q___), real_ v_, real_real_ Q]); \ -\ Q__ = Rewrite Querkraft_Moment True Q__; \ -\ (M__::bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs Q__), real_ v_, real_real_ M_b]); \ -\ e1__ = nth_ 1 rm_; \ -\ (x1__::real) = argument_in (lhs e1__); \ -\ (M1__::bool) = (Substitute [v_ = x1__]) M__; \ -\ M1__ = (Substitute [e1__]) M1__ ; \ -\ M2__ = Take M__; "^ -(*without this Take 'Substitute [v_ = x2__]' takes _last formula from ctree_*) -" e2__ = nth_ 2 rm_; \ -\ (x2__::real) = argument_in (lhs e2__); \ -\ (M2__::bool) = ((Substitute [v_ = x2__]) @@ \ -\ (Substitute [e2__])) M2__; \ -\ (c_1_2__::bool list) = \ -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ -\ [booll_ [M1__, M2__], reall [c,c_2]]); \ -\ M__ = Take M__; \ -\ M__ = ((Substitute c_1_2__) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, c),(bdv_2, c_2)]\ -\ simplify_System False)) @@ \ -\ (Rewrite Moment_Neigung False) @@ \ -\ (Rewrite make_fun_explicit False)) M__; "^ -(*----------------------- and the same once more ------------------------*) -" (N__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs M__), real_ v_, real_real_ y']); \ -\ (B__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs N__), real_ v_, real_real_ y]); \ -\ e1__ = nth_ 1 rb_; \ -\ (x1__::real) = argument_in (lhs e1__); \ -\ (B1__::bool) = (Substitute [v_ = x1__]) B__; \ -\ B1__ = (Substitute [e1__]) B1__ ; \ -\ B2__ = Take B__; \ -\ e2__ = nth_ 2 rb_; \ -\ (x2__::real) = argument_in (lhs e2__); \ -\ (B2__::bool) = ((Substitute [v_ = x2__]) @@ \ -\ (Substitute [e2__])) B2__; \ -\ (c_1_2__::bool list) = \ -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ -\ [booll_ [B1__, B2__], reall [c,c_2]]); \ -\ B__ = Take B__; \ -\ B__ = ((Substitute c_1_2__) @@ \ -\ (Rewrite_Set_Inst [(bdv, x)] make_ratpoly_in False)) B__ \ -\ in B__)" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_2" [] e_metID - (["IntegrierenUndKonstanteBestimmen2"], - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__", - "FunktionsVariable v_"]), - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) - ("#Find" ,["Biegelinie b_"]), - ("#Relate",["Randbedingungen rb_"]) - ], - {rew_ord'="tless_true", - rls' = append_rls "erls_IntegrierenUndK.." e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false)], - calc = [], - srls = append_rls "erls_IntegrierenUndK.." e_rls - [Calc("Tools.rhs", eval_rhs"eval_rhs_"), - Calc ("Atools.ident",eval_ident "#ident_"), - Thm ("last_thmI",num_str last_thmI), - Thm ("if_True",num_str if_True), - Thm ("if_False",num_str if_False) - ], - prls = Erls, crls = Atools_erls, nrls = Erls}, -"Script Biegelinie2Script \ -\(l_::real) (q__::real) (v_::real) (b_::real=>real) (rb_::bool list) = \ -\ (let \ -\ (funs_:: bool list) = \ -\ (SubProblem (Biegelinie_,[vonBelastungZu,Biegelinien], \ -\ [Biegelinien,ausBelastung]) \ -\ [real_ q__, real_ v_]); \ -\ (equs_::bool list) = \ -\ (SubProblem (Biegelinie_,[setzeRandbedingungen,Biegelinien],\ -\ [Biegelinien,setzeRandbedingungenEin]) \ -\ [booll_ funs_, booll_ rb_]); \ -\ (cons_::bool list) = \ -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ -\ [booll_ equs_, reall [c,c_2,c_3,c_4]]); \ -\ B_ = Take (lastI funs_); \ -\ B_ = ((Substitute cons_) @@ \ -\ (Rewrite_Set_Inst [(bdv, v_)] make_ratpoly_in False)) B_ \ -\ in B_)" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_intconst_2" [] e_metID - (["IntegrierenUndKonstanteBestimmen","2xIntegrieren"], - [], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"empty_script" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_intconst_4" [] e_metID - (["IntegrierenUndKonstanteBestimmen","4x4System"], - [], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"empty_script" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_intconst_1" [] e_metID - (["IntegrierenUndKonstanteBestimmen","1xIntegrieren"], - [], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"empty_script" -)); - -store_met - (prep_met Biegelinie.thy "met_biege2" [] e_metID - (["Biegelinien"], - [], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"empty_script" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_ausbelast" [] e_metID - (["Biegelinien","ausBelastung"], - [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]), - ("#Find" ,["Funktionen funs_"])], - {rew_ord'="tless_true", - rls' = append_rls "erls_ausBelastung" e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false)], - calc = [], - srls = append_rls "srls_ausBelastung" e_rls - [Calc("Tools.rhs", eval_rhs"eval_rhs_")], - prls = e_rls, crls = Atools_erls, nrls = e_rls}, -"Script Belastung2BiegelScript (q__::real) (v_::real) = \ -\ (let q___ = Take (q_ v_ = q__); \ -\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \ -\ (Rewrite Belastung_Querkraft True)) q___; \ -\ (Q__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs q___), real_ v_, real_real_ Q]); \ -\ M__ = Rewrite Querkraft_Moment True Q__; \ -\ (M__::bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs M__), real_ v_, real_real_ M_b]); \ -\ N__ = ((Rewrite Moment_Neigung False) @@ \ -\ (Rewrite make_fun_explicit False)) M__; \ -\ (N__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs N__), real_ v_, real_real_ y']); \ -\ (B__:: bool) = \ -\ (SubProblem (Biegelinie_,[named,integrate,function], \ -\ [diff,integration,named]) \ -\ [real_ (rhs N__), real_ v_, real_real_ y]) \ -\ in [Q__, M__, N__, B__])" -)); - -store_met - (prep_met Biegelinie.thy "met_biege_setzrand" [] e_metID - (["Biegelinien","setzeRandbedingungenEin"], - [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]), - ("#Find" ,["Gleichungen equs___"])], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = srls2, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \ -\ (let b1_ = nth_ 1 rb_; \ -\ fs_ = filter_sameFunId (lhs b1_) funs_; \ -\ (e1_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b1_]); \ -\ b2_ = nth_ 2 rb_; \ -\ fs_ = filter_sameFunId (lhs b2_) funs_; \ -\ (e2_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b2_]); \ -\ b3_ = nth_ 3 rb_; \ -\ fs_ = filter_sameFunId (lhs b3_) funs_; \ -\ (e3_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b3_]); \ -\ b4_ = nth_ 4 rb_; \ -\ fs_ = filter_sameFunId (lhs b4_) funs_; \ -\ (e4_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b4_]) \ -\ in [e1_,e2_,e3_,e4_])" -(* filter requires more than 1 sec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \ -\ (let b1_ = nth_ 1 rb_; \ -\ fs_ = filter (sameFunId (lhs b1_)) funs_; \ -\ (e1_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b1_]); \ -\ b2_ = nth_ 2 rb_; \ -\ fs_ = filter (sameFunId (lhs b2_)) funs_; \ -\ (e2_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b2_]); \ -\ b3_ = nth_ 3 rb_; \ -\ fs_ = filter (sameFunId (lhs b3_)) funs_; \ -\ (e3_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b3_]); \ -\ b4_ = nth_ 4 rb_; \ -\ fs_ = filter (sameFunId (lhs b4_)) funs_; \ -\ (e4_::bool) = \ -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ -\ [Equation,fromFunction]) \ -\ [bool_ (hd fs_), bool_ b4_]) \ -\ in [e1_,e2_,e3_,e4_])"*) -)); - -store_met - (prep_met Biegelinie.thy "met_equ_fromfun" [] e_metID - (["Equation","fromFunction"], - [("#Given" ,["functionEq fun_","substitution sub_"]), - ("#Find" ,["equality equ___"])], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = append_rls "srls_in_EquationfromFunc" e_rls - [Calc("Tools.lhs", eval_lhs"eval_lhs_"), - Calc("Atools.argument'_in", - eval_argument_in - "Atools.argument'_in")], - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -(*(M_b x = c_2 + c * x + -1 * q_0 / 2 * x ^^^ 2) (M_b L = 0) --> - 0 = c_2 + c * L + -1 * q_0 / 2 * L ^^^ 2*) -"Script Function2Equality (fun_::bool) (sub_::bool) =\ -\ (let fun_ = Take fun_; \ -\ bdv_ = argument_in (lhs fun_); \ -\ val_ = argument_in (lhs sub_); \ -\ equ_ = (Substitute [bdv_ = val_]) fun_; \ -\ equ_ = (Substitute [sub_]) fun_ \ -\ in (Rewrite_Set norm_Rational False) equ_) " -)); - - - -(* use"IsacKnowledge/Biegelinie.ML"; - *) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Biegelinie.thy --- a/src/Tools/isac/IsacKnowledge/Biegelinie.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -(* chapter 'Biegelinie' from the textbook: - Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271. - author: Walther Neuper - 050826, - (c) due to copyright terms - -remove_thy"Biegelinie"; -use_thy"IsacKnowledge/Biegelinie"; -use_thy_only"IsacKnowledge/Biegelinie"; - -remove_thy"Biegelinie"; -use_thy"IsacKnowledge/Isac"; -*) - -Biegelinie = Integrate + Equation + EqSystem + - -consts - - q_ :: real => real ("q'_") (* Streckenlast *) - Q :: real => real (* Querkraft *) - Q' :: real => real (* Ableitung der Querkraft *) - M'_b :: real => real ("M'_b") (* Biegemoment *) - M'_b' :: real => real ("M'_b'") (* Ableitung des Biegemoments *) - y'' :: real => real (* 2.Ableitung der Biegeline *) - y' :: real => real (* Neigung der Biegeline *) -(*y :: real => real (* Biegeline *)*) - EI :: real (* Biegesteifigkeit *) - - (*new Descriptions in the related problems*) - Traegerlaenge :: real => una - Streckenlast :: real => una - BiegemomentVerlauf :: bool => una - Biegelinie :: (real => real) => una - Randbedingungen :: bool list => una - RandbedingungenBiegung :: bool list => una - RandbedingungenNeigung :: bool list => una - RandbedingungenMoment :: bool list => una - RandbedingungenQuerkraft :: bool list => una - FunktionsVariable :: real => una - Funktionen :: bool list => una - Gleichungen :: bool list => una - - (*Script-names*) - Biegelinie2Script :: "[real,real,real,real=>real,bool list, - bool] => bool" - ("((Script Biegelinie2Script (_ _ _ _ _ =))// (_))" 9) - BiegelinieScript :: "[real,real,real,real=>real,bool list,bool list, - bool] => bool" - ("((Script BiegelinieScript (_ _ _ _ _ _ =))// (_))" 9) - Biege2xIntegrierenScript :: "[real,real,real,bool,real=>real,bool list, - bool] => bool" - ("((Script Biege2xIntegrierenScript (_ _ _ _ _ _ =))// (_))" 9) - Biege4x4SystemScript :: "[real,real,real,real=>real,bool list, - bool] => bool" - ("((Script Biege4x4SystemScript (_ _ _ _ _ =))// (_))" 9) - Biege1xIntegrierenScript :: - "[real,real,real,real=>real,bool list,bool list,bool list, - bool] => bool" - ("((Script Biege1xIntegrierenScript (_ _ _ _ _ _ _ =))// (_))" 9) - Belastung2BiegelScript :: "[real,real, - bool list] => bool list" - ("((Script Belastung2BiegelScript (_ _ =))// (_))" 9) - SetzeRandbedScript :: "[bool list,bool list, - bool list] => bool list" - ("((Script SetzeRandbedScript (_ _ =))// (_))" 9) - -rules - - Querkraft_Belastung "Q' x = -q_ x" - Belastung_Querkraft "-q_ x = Q' x" - - Moment_Querkraft "M_b' x = Q x" - Querkraft_Moment "Q x = M_b' x" - - Neigung_Moment "y'' x = -M_b x/ EI" - Moment_Neigung "M_b x = -EI * y'' x" - - (*according to rls 'simplify_Integral': .. = 1/a * .. instead .. = ../ a*) - make_fun_explicit "Not (a =!= 0) ==> (a * (f x) = b) = (f x = 1/a * b)" - -end - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Calculus.thy --- a/src/Tools/isac/IsacKnowledge/Calculus.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ - -Calculus = Real + - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Descript.thy --- a/src/Tools/isac/IsacKnowledge/Descript.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ -(* Title: descriptions for items in model-patterns of problems and in method's - guards - Author: Walther Neuper 000301 - (c) due to copyright terms - + see WN, Reactive User-Guidance ... Vers. Oct.2000 p.48 ff - -remove_thy"Descript"; -use_thy"IsacKnowledge/Descript"; -use_thy_only"IsacKnowledge/Descript"; - -remove_thy"Typefix"; -use_thy"IsacKnowledge/Isac"; -*) - -theory Descript imports "../Scripts/Script" begin - -consts - - someList :: "'a list => unl" (*not for elementwise input, eg. inssort*) - - additionalRels :: "bool list => una" - boundVariable :: "real => una" -(*derivative :: 'a => toreal 28.11.00*) - derivative :: "real => una" - equalities :: "bool list => tobooll" (*WN071228 see fixedValues*) - equality :: "bool => una" - errorBound :: "bool => nam" - - fixedValues :: "bool list => nam" - functionEq :: "bool => una" (*6.5.03: functionTerm -> functionEq*) - antiDerivative :: "bool => una" - functionOf :: "real => una" -(*functionTerm :: 'a => toreal 28.11.00*) - functionTerm :: "real => una" (*6.5.03: functionTerm -> functionEq*) - interval :: "real set => una" - maxArgument :: "bool => toreal" - maximum :: "real => toreal" - - relations :: "bool list => una" - solutions :: "bool list => toreall" -(*solution :: bool => toreal WN0509 bool list=> toreall --->EqSystem*) - solveFor :: "real => una" - differentiateFor:: "real => una" - unknown :: "'a => unknow" - valuesFor :: "real list => toreall" - - realTestGiven :: "real => una" - realTestFind :: "real => una" - boolTestGiven :: "bool => una" - boolTestFind :: "bool => una" - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Diff.ML --- a/src/Tools/isac/IsacKnowledge/Diff.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,370 +0,0 @@ -(* tools for differentiation - WN.11.99 - -use"IsacKnowledge/Diff.ML"; -use"Diff.ML"; - *) - - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("Diff.thy",Diff.thy)]); - - -(** eval functions **) - -fun primed (Const (id, T)) = Const (id ^ "'", T) - | primed (Free (id, T)) = Free (id ^ "'", T) - | primed t = raise error ("primed called with arg = '"^ term2str t ^"'"); - -(*("primed", ("Diff.primed", eval_primed "#primed"))*) -fun eval_primed _ _ (p as (Const ("Diff.primed",_) $ t)) _ = - SOME ((term2str p) ^ " = " ^ term2str (primed t), - Trueprop $ (mk_equality (p, primed t))) - | eval_primed _ _ _ _ = NONE; - -calclist':= overwritel (!calclist', - [("primed", ("Diff.primed", eval_primed "#primed")) - ]); - - -(** rulesets **) - -(*.converts a term such that differentiation works optimally.*) -val diff_conv = - Rls {id="diff_conv", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = append_rls "erls_diff_conv" e_rls - [Calc ("Atools.occurs'_in", eval_occurs_in ""), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Calc ("op <",eval_equ "#less_"), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false) - ], - srls = Erls, calc = [], - rules = [Thm ("frac_conv", num_str frac_conv), - Thm ("sqrt_conv_bdv", num_str sqrt_conv_bdv), - Thm ("sqrt_conv_bdv_n", num_str sqrt_conv_bdv_n), - Thm ("sqrt_conv", num_str sqrt_conv), - Thm ("root_conv", num_str root_conv), - Thm ("realpow_pow_bdv", num_str realpow_pow_bdv), - Calc ("op *", eval_binop "#mult_"), - Thm ("rat_mult",num_str rat_mult), - (*a / b * (c / d) = a * c / (b * d)*) - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), - (*?x * (?y / ?z) = ?x * ?y / ?z*) - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq) - (*?y / ?z * ?x = ?y * ?x / ?z*) - (* - Thm ("", num_str ),*) - ], - scr = EmptyScr}; - -(*.beautifies a term after differentiation.*) -val diff_sym_conv = - Rls {id="diff_sym_conv", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = append_rls "erls_diff_sym_conv" e_rls - [Calc ("op <",eval_equ "#less_") - ], - srls = Erls, calc = [], - rules = [Thm ("frac_sym_conv", num_str frac_sym_conv), - Thm ("sqrt_sym_conv", num_str sqrt_sym_conv), - Thm ("root_sym_conv", num_str root_sym_conv), - Thm ("sym_real_mult_minus1", - num_str (real_mult_minus1 RS sym)), - (*- ?z = "-1 * ?z"*) - Thm ("rat_mult",num_str rat_mult), - (*a / b * (c / d) = a * c / (b * d)*) - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), - (*?x * (?y / ?z) = ?x * ?y / ?z*) - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), - (*?y / ?z * ?x = ?y * ?x / ?z*) - Calc ("op *", eval_binop "#mult_") - ], - scr = EmptyScr}; - -(*..*) -val srls_diff = - Rls {id="srls_differentiate..", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = e_rls, - srls = Erls, calc = [], - rules = [Calc("Tools.lhs", eval_lhs "eval_lhs_"), - Calc("Tools.rhs", eval_rhs "eval_rhs_"), - Calc("Diff.primed", eval_primed "Diff.primed") - ], - scr = EmptyScr}; - -(*..*) -val erls_diff = - append_rls "erls_differentiate.." e_rls - [Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Atools.is'_const",eval_const "#is_const_") - ]; - -(*.rules for differentiation, _no_ simplification.*) -val diff_rules = - Rls {id="diff_rules", preconds = [], rew_ord = ("termlessI",termlessI), - erls = erls_diff, srls = Erls, calc = [], - rules = [Thm ("diff_sum",num_str diff_sum), - Thm ("diff_dif",num_str diff_dif), - Thm ("diff_prod_const",num_str diff_prod_const), - Thm ("diff_prod",num_str diff_prod), - Thm ("diff_quot",num_str diff_quot), - Thm ("diff_sin",num_str diff_sin), - Thm ("diff_sin_chain",num_str diff_sin_chain), - Thm ("diff_cos",num_str diff_cos), - Thm ("diff_cos_chain",num_str diff_cos_chain), - Thm ("diff_pow",num_str diff_pow), - Thm ("diff_pow_chain",num_str diff_pow_chain), - Thm ("diff_ln",num_str diff_ln), - Thm ("diff_ln_chain",num_str diff_ln_chain), - Thm ("diff_exp",num_str diff_exp), - Thm ("diff_exp_chain",num_str diff_exp_chain), -(* - Thm ("diff_sqrt",num_str diff_sqrt), - Thm ("diff_sqrt_chain",num_str diff_sqrt_chain), -*) - Thm ("diff_const",num_str diff_const), - Thm ("diff_var",num_str diff_var) - ], - scr = EmptyScr}; - -(*.normalisation for checking user-input.*) -val norm_diff = - Rls {id="diff_rls", preconds = [], rew_ord = ("termlessI",termlessI), - erls = Erls, srls = Erls, calc = [], - rules = [Rls_ diff_rules, - Rls_ norm_Poly - ], - scr = EmptyScr}; -ruleset' := -overwritelthy thy (!ruleset', - [("diff_rules", prep_rls norm_diff), - ("norm_diff", prep_rls norm_diff), - ("diff_conv", prep_rls diff_conv), - ("diff_sym_conv", prep_rls diff_sym_conv) - ]); - - -(** problem types **) - -store_pbt - (prep_pbt Diff.thy "pbl_fun" [] e_pblID - (["function"], [], e_rls, NONE, [])); - -store_pbt - (prep_pbt Diff.thy "pbl_fun_deriv" [] e_pblID - (["derivative_of","function"], - [("#Given" ,["functionTerm f_","differentiateFor v_"]), - ("#Find" ,["derivative f_'_"]) - ], - append_rls "e_rls" e_rls [], - SOME "Diff (f_, v_)", [["diff","differentiate_on_R"], - ["diff","after_simplification"]])); - -(*here "named" is used differently from Integration"*) -store_pbt - (prep_pbt Diff.thy "pbl_fun_deriv_nam" [] e_pblID - (["named","derivative_of","function"], - [("#Given" ,["functionEq f_","differentiateFor v_"]), - ("#Find" ,["derivativeEq f_'_"]) - ], - append_rls "e_rls" e_rls [], - SOME "Differentiate (f_, v_)", [["diff","differentiate_equality"]])); - - -(** methods **) - -store_met - (prep_met Diff.thy "met_diff" [] e_metID - (["diff"], [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls = Atools_erls, nrls = norm_diff}, "empty_script")); - -store_met - (prep_met Diff.thy "met_diff_onR" [] e_metID - (["diff","differentiate_on_R"], - [("#Given" ,["functionTerm f_","differentiateFor v_"]), - ("#Find" ,["derivative f_'_"]) - ], - {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls, - prls=e_rls, crls = Atools_erls, nrls = norm_diff}, -"Script DiffScr (f_::real) (v_::real) = \ -\ (let f'_ = Take (d_d v_ f_) \ -\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ -\ (Repeat \ -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ -\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)" -)); - -store_met - (prep_met Diff.thy "met_diff_simpl" [] e_metID - (["diff","diff_simpl"], - [("#Given" ,["functionTerm f_","differentiateFor v_"]), - ("#Find" ,["derivative f_'_"]) - ], - {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls, - prls=e_rls, crls = Atools_erls, nrls = norm_diff}, -"Script DiffScr (f_::real) (v_::real) = \ -\ (let f'_ = Take (d_d v_ f_) \ -\ in (( \ -\ (Repeat \ -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ -\ (Repeat (Rewrite_Set make_polynomial False)))) \ -\ )) f'_)" - )); - -(*----------------------------------------------------------------- - "Script DiffScr (f_::real) (v_::real) = \ - \(Repeat \ - \ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ - \ (Repeat (Rewrite_Set make_polynomial False)))) \ - \ (f_::real)" -*) - -store_met - (prep_met Diff.thy "met_diff_equ" [] e_metID - (["diff","differentiate_equality"], - [("#Given" ,["functionEq f_","differentiateFor v_"]), - ("#Find" ,["derivativeEq f_'_"]) - ], - {rew_ord'="tless_true", rls' = erls_diff, calc = [], - srls = srls_diff, prls=e_rls, crls=Atools_erls, nrls = norm_diff}, -"Script DiffEqScr (f_::bool) (v_::real) = \ -\ (let f'_ = Take ((primed (lhs f_)) = d_d v_ (rhs f_)) \ -\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ -\ (Repeat \ -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_dif False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ -\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)" -)); - - -store_met - (prep_met Diff.thy "met_diff_after_simp" [] e_metID - (["diff","after_simplification"], - [("#Given" ,["functionTerm f_","differentiateFor v_"]), - ("#Find" ,["derivative f_'_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, prls=e_rls, - crls=Atools_erls, nrls = norm_Rational}, -"Script DiffScr (f_::real) (v_::real) = \ -\ (let f'_ = Take (d_d v_ f_) \ -\ in ((Try (Rewrite_Set norm_Rational False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv,v_)] norm_diff False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)) @@ \ -\ (Try (Rewrite_Set norm_Rational False))) f'_)" -)); - - -(** CAS-commands **) - -(*.handle cas-input like "Diff (a * x^3 + b, x)".*) -(* val (t, pairl) = strip_comb (str2term "Diff (a * x^3 + b, x)"); - val [Const ("Pair", _) $ t $ bdv] = pairl; - *) -fun argl2dtss [Const ("Pair", _) $ t $ bdv] = - [((term_of o the o (parse thy)) "functionTerm", [t]), - ((term_of o the o (parse thy)) "differentiateFor", [bdv]), - ((term_of o the o (parse thy)) "derivative", - [(term_of o the o (parse thy)) "f_'_"]) - ] - | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss"; -castab := -overwritel (!castab, - [((term_of o the o (parse thy)) "Diff", - (("Isac.thy", ["derivative_of","function"], ["no_met"]), - argl2dtss)) - ]); - -(*.handle cas-input like "Differentiate (A = s * (a - s), s)".*) -(* val (t, pairl) = strip_comb (str2term "Differentiate (A = s * (a - s), s)"); - val [Const ("Pair", _) $ t $ bdv] = pairl; - *) -fun argl2dtss [Const ("Pair", _) $ t $ bdv] = - [((term_of o the o (parse thy)) "functionEq", [t]), - ((term_of o the o (parse thy)) "differentiateFor", [bdv]), - ((term_of o the o (parse thy)) "derivativeEq", - [(term_of o the o (parse thy)) "f_'_::bool"]) - ] - | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss"; -castab := -overwritel (!castab, - [((term_of o the o (parse thy)) "Differentiate", - (("Isac.thy", ["named","derivative_of","function"], ["no_met"]), - argl2dtss)) - ]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Diff.thy --- a/src/Tools/isac/IsacKnowledge/Diff.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,97 +0,0 @@ -(* differentiation over the reals - author: Walther Neuper - 000516 - -remove_thy"Diff"; -use_thy_only"IsacKnowledge/Diff"; -use_thy"IsacKnowledge/Isac"; - *) - -Diff = Calculus + Trig + LogExp + Rational + Root + Poly + Atools + - -consts - - d_d :: "[real, real]=> real" - sin, cos :: "real => real" -(* - log, ln :: "real => real" - nlog :: "[real, real] => real" - exp :: "real => real" ("E'_ ^^^ _" 80) -*) - (*descriptions in the related problems*) - derivativeEq :: bool => una - - (*predicates*) - primed :: "'a => 'a" (*"primed A" -> "A'"*) - - (*the CAS-commands, eg. "Diff (2*x^^^3, x)", - "Differentiate (A = s * (a - s), s)"*) - Diff :: "[real * real] => real" - Differentiate :: "[bool * real] => bool" - - (*subproblem and script-name*) - differentiate :: "[ID * (ID list) * ID, real,real] => real" - ("(differentiate (_)/ (_ _ ))" 9) - DiffScr :: "[real,real, real] => real" - ("((Script DiffScr (_ _ =))// (_))" 9) - DiffEqScr :: "[bool,real, bool] => bool" - ("((Script DiffEqScr (_ _ =))// (_))" 9) - - -rules (*stated as axioms, todo: prove as theorems - 'bdv' is a constant on the meta-level *) - diff_const "[| Not (bdv occurs_in a) |] ==> d_d bdv a = 0" - diff_var "d_d bdv bdv = 1" - diff_prod_const"[| Not (bdv occurs_in u) |] ==> \ - \d_d bdv (u * v) = u * d_d bdv v" - - diff_sum "d_d bdv (u + v) = d_d bdv u + d_d bdv v" - diff_dif "d_d bdv (u - v) = d_d bdv u - d_d bdv v" - diff_prod "d_d bdv (u * v) = d_d bdv u * v + u * d_d bdv v" - diff_quot "Not (v = 0) ==> (d_d bdv (u / v) = \ - \(d_d bdv u * v - u * d_d bdv v) / v ^^^ 2)" - - diff_sin "d_d bdv (sin bdv) = cos bdv" - diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u" - diff_cos "d_d bdv (cos bdv) = - sin bdv" - diff_cos_chain "d_d bdv (cos u) = - sin u * d_d bdv u" - diff_pow "d_d bdv (bdv ^^^ n) = n * (bdv ^^^ (n - 1))" - diff_pow_chain "d_d bdv (u ^^^ n) = n * (u ^^^ (n - 1)) * d_d bdv u" - diff_ln "d_d bdv (ln bdv) = 1 / bdv" - diff_ln_chain "d_d bdv (ln u) = d_d bdv u / u" - diff_exp "d_d bdv (exp bdv) = exp bdv" - diff_exp_chain "d_d bdv (exp u) = exp u * d_d x u" -(* - diff_sqrt "d_d bdv (sqrt bdv) = 1 / (2 * sqrt bdv)" - diff_sqrt_chain"d_d bdv (sqrt u) = d_d bdv u / (2 * sqrt u)" -*) - (*...*) - - frac_conv "[| bdv occurs_in b; 0 < n |] ==> \ - \ a / (b ^^^ n) = a * b ^^^ (-n)" - frac_sym_conv "n < 0 ==> a * b ^^^ n = a / b ^^^ (-n)" - - sqrt_conv_bdv "sqrt bdv = bdv ^^^ (1 / 2)" - sqrt_conv_bdv_n "sqrt (bdv ^^^ n) = bdv ^^^ (n / 2)" - sqrt_conv "bdv occurs_in u ==> sqrt u = u ^^^ (1 / 2)" - sqrt_sym_conv "u ^^^ (a / 2) = sqrt (u ^^^ a)" - - root_conv "bdv occurs_in u ==> nroot n u = u ^^^ (1 / n)" - root_sym_conv "u ^^^ (a / b) = nroot b (u ^^^ a)" - - realpow_pow_bdv "(bdv ^^^ b) ^^^ c = bdv ^^^ (b * c)" - -end - -(* a variant of the derivatives defintion: - - d_d :: "(real => real) => (real => real)" - - advantages: -(1) no variable 'bdv' on the meta-level required -(2) chain_rule "d_d (%x. (u (v x))) = (%x. (d_d u)) (v x) * d_d v" -(3) and no specialized chain-rules required like - diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u" - - disadvantage: d_d (%x. 1 + x^2) = ... differs from high-school notation -*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp-oldpbl.sml --- a/src/Tools/isac/IsacKnowledge/DiffApp-oldpbl.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,369 +0,0 @@ -(*8.01: aufgehoben wegen alter preconds, postconds*) - -(* rectangle with maximal area, inscribed in a circle of fixed radius - -problem-types and methods solving the respective problem-type - -(1) names of the problem-types and methods and their hierarchy - as subproblems. - names of problem-types are string lists (diss 5.3.), not shown - here with exception of ["equation","univariate"] in order to - indicate, that this particular problem needs refinement to a - more specific type of equation solvable by tan-square, etc. - -problem-types methods -------------------------------- ---------------------- -maximum maximum-by-differentiation - maximum-by-experimentation - make-fun make-explicit-and-substitute - introduce-a-new-variable - max-of-fun-on-interval max-of-fun-on-interval - derivative differentiate - ["equation","univariate"] tan-square - - find-values find-values - -(2) specification of the problem-types -*) - -(* maximum *) -(* ------- *) -(* problem-type *) -{given = ["fixed_values (cs::bool list)"], - where_= ["foldl (op &) True (map is_equality cs)", - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"], - find=["maximum m","values_for (ms::real list)"], - with_=["Ex_frees ((foldl (op &) True (r#RS)) & \ - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#RS)) \ - \ --> m' <= m)))"], - relate=["max_relation r","additional_relations RS"]}; -(* ^^^ is exponenation *) - -(* the functions Ex_frees, Rhs provide for the instantiation below *) - -(* (1) instantiation of maximum, + variant in "values_for" *) -{given = ["fixed_values (R = #7)"], - where_= ["is_equality (R = #7)", - "Not (R <= #0)"], - find =["maximum A","values_for [a,b]"], - with_ =["EX A. A = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \ - \ (ALL A'. A' = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \ - \ --> A' <= A)))"], - relate=["max_relation (A = a*b)", - "additional_relations [(a//#2)^^^#2 +(b//#2)^^^#2 =R^^^#2]"]}; -(* R,a,b are bound by given, find *) - -(* (2) instantiation of maximum *) -{given = ["fixed_values (R = #7)"], - where_= ["is_equality (R = #7)", - "Not (R <= #0)"], - find =["maximum A","values_for [A]"], - with_ =["EX a b alpha. A = a*b & \ - \ a = #2*R*sin alpha & b =#2*R*cos alpha &\ - \ (ALL A'. A' = a*b & a = #2*R*sin alpha & b =#2*R*cos alpha \ - \ --> A' <= A)))"], - relate=["max_relation (A = a*b)", - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]}; -(* R,A are bound by given, find *) - - -(* make-fun *) -(* -------- *) -(* problem-type *) -{given = ["equality (lhs = rhs)","bound_variable v","equalities es"], - where_= [], - find = ["function_term lhs_"], - with_ = [(*???*)], - relate= [(*???*)]}; -(*the _ in lhs is used to transfer the lhs-identifier of equality*) - -(* (1) instantiation for make-explicit-and-substitute *) -{given = ["equality A = a * b","bound_variable a", - "equalities [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"], - where_= [], - find = ["function_term A_"(*=(a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))*)], - with_ = [], - relate= []}; - -(* (2) instantiation for introduce-a-new-variable *) -{given = ["equality A = a * b","bound_variable alpha", - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], - where_= [], - find = ["function_term A_"(*=(#2*R*sin alpha *#2*R*cos alpha)*)], - with_ = [], - relate= []}; - - -(* max-of-fun-on-interval *) -(* ---------------------- *) -(* problem-type *) -{given = ["function_term t","bound_variable v", - "domain {x::real. lower_bound <= x & x <= upper_bound}"], - where_= [], - find = ["maximums ms"], - with_ = ["ALL m. m : ms --> \ - \ (ALL x::real. lower_bound <= x & x <= upper_bound \ - \ --> (%v. t) x <= m)"], - relate= []}: string ppc; -(* ':' is 'element', '::' is a type constraint *) - -(* (1) variant of instantiation *) -{given = ["function_term (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))", - "bound_variable a", - "domain {x::real. #0 <= x & x <= #2*R}"], - where_= [], - find = ["maximums AM"], - with_ = ["ALL am. am : AM --> \ - \ (ALL x::real. #0 <= x & x <= #2*R \ - \ --> (%a. (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))) x <= am)"], - relate= []}; - -(* (2) variant of instantiation *) -{given = ["function_term (#2*R*sin alpha * #2*R*cos alpha)", - "bound_variable alpha", - "domain {x::real. #0 <= x & x <= pi//#2}"], - where_= [], - find = ["maximums AM"], - with_ = ["ALL am. am : AM --> \ - \ (ALL x::real. #0 <= x & x <= pi//#2 \ - \ --> (%alpha. (#2*R*sin alpha * #2*R*cos alpha)) x <= am)"], - relate= []}; - - -(* derivative *) -(* ---------- *) -(* problem-type *) -{given = ["function_term t","bound_variable bdv"], - where_= [], - find = ["derivative t'"], - with_ = ["t' is_derivative_of (%bdv. t)"], - relate= []}; -(*the ' in t' is used to transfer the identifier from function_term*) - - -(* ["equation","univariate"] *) -(* ------------------------- *) -(* problem-type *) -{given = ["equality (lhs = rhs)", - "bound_variable v","error_bound eps"], - where_= [], - find = ["solutions S"], - with_ = ["ALL s. s : S --> || (%v. lhs) s - (%v. rhs) s || <= eps"], - relate= []}; - - -(* find-values *) -(* ----------- *) -(* problem-type *) -{given = ["max_relation r","additional_relations RS"], - where_= [], - find = ["values_for VS"], - with_ = [(*???*)], - relate= []}; - -(* (1) variant of instantiation *) -{given = ["max_relation (A = a*b)", - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]"], - where_= [], - find = ["values_for [a,b]"], - with_ = [], - relate= []}; - -(* (2) variant of instantiation *) -{given = ["max_relation (A = a*b)",], - where_= [], - find = ["values_for [A]", - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"], - with_ = [], - relate= []}; - -(* -(3) data-transfer between the the hidden formalization, - the root-problem and the sub-problems; - -maximum -> #given.make-fun -------------------- -maximum.#relate "max_relation r" -> "equality (lhs = rhs)" -formalization "bound_variable v" -> "bound_variable v" -maximum.#relate "additional_relations RS"-> "equalities es" - - -maximum + make-fun -> #given.max-of-fun-on-interval --------------------------------------------- -make-fun.#find "function_term lhs_" -> "function_term t" -make-fun.#given "bound_variable v" -> "bound_variable v" -formalization -> "domain {x::real. ...}" - - -max-of-fun-on-interval -> #given.derivative ------------------------------------- -make-fun.#find "function_term lhs_" -> "function_term t" -make-fun.#given "bound_variable v" -> "bound_variable bdv" - - -max-of-fun-on-interval + derivative -> - #given.["equation","univariate"] ----------------------------------------------------------------- -derivative.#find "derivative t'" -> "equality (lhs = rhs)" - (* t'= #0 *) -make-fun.#given "bound_variable v" -> "bound_variable v" -formalization -> "error_bound eps" - - -maximum + make-fun + max-of-fun-on-interval -> #given.find-values ----------------------------------------------------------- -maximum.#relate "max_relation r" -> "max_relation r" -maximum.#relate "additional_relations RS"-> "additional_relations RS" -*) - - - - -(* vvv--- geht nicht wegen fun-types -parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')"; -parse thy "if maxmin = is_max then (m' <= m) else (m <= m')"; -parse thy "if a=b then a else b"; -parse thy "maxmin = is_max"; -parse thy "maxmin =!= is_max"; - ^^^--- geht nicht wegen fun-types *) - -"pbltyp --- maximum ---"; -val pbltyp = {given=["fixed_values (cs::bool list)"], - where_=["foldl (op &) True (map is_equality cs)", - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"], - find=["maximum m","values_for (ms::real list)"], - with_=["Ex_frees ((foldl (op &) True (r#rs)) & \ - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \ - \ --> m' <= m)))"], - relate=["max_relation r","additional_relations rs"]}:string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val org = ["fixed_values [R=(R::real)]", - "bound_variable a", "bound_variable b", "bound_variable alpha", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= pi}", - "maximum A", - "max_relation A=#2*a*b - a^^^#2", - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]; -val chkorg = map (the o (parse thy)) org; -val pbl = {given=["fixed_values [R=(R::real)]"],where_=[], - find=["maximum A","values_for [a,b]"], - with_=["EX alpha. A=#2*a*b - a^^^#2 & \ - \ a=#2*R*sin alpha & b=#2*R*cos alpha & \ - \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha & b=#2*R*cos alpha \ - \ --> A' <= A)"], - relate=["max_relation (A=#2*a*b - a^^^#2)", - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"] - }: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - -"met --- maximum_by_differentiation ---"; -val met = {given=["fixed_values (cs::bool list)","bound_variable v", - "domain {x::real. lower_bound <= x & x <= upper_bound}", - "approximation apx"], - where_=[], - find=["maximum m","values_for (ms::real list)", - "function_term t","max_argument mx"], - with_=["Ex_frees ((foldl (op &) True (rs::bool list)) & \ - \ (ALL m'. (subst (m,m') (foldl (op &) True rs) \ - \ --> m' <= m))) & \ - \m = (%v. t) mx & \ - \( ALL x. lower_bound <= x & x <= upper_bound \ - \ --> (%v. t) x <= m)"], - relate=["rs::bool list"]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) met; - - -"pbltyp --- make_fun ---"; -(* subproblem [(hd #relate root, equality), - (bound_variable formalization, bound_variable), - (tl #relate root, equalities)] *) -val pbltyp = {given=["equality e","bound_variable v", "equalities es"], - where_=[], - find=["function_term t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val pbl = {given=["equality (A=#2*a*b - a^^^#2)","bound_variable alpha", - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], - where_=[], - find=["function_term t"], - with_=[],relate=[]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - -"met --- make_explicit_and_substitute ---"; -val met = {given=["equality e","bound_variable v", "equalities es"], - where_=[], - find=["function_term t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkmet = ((map (the o (parse thy))) o ppc2list) met; -"met --- introduce_a_new_variable ---"; -val met = {given=["equality e","bound_variable v", "substitutions es"], - where_=[], - find=["function_term t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkmet = ((map (the o (parse thy))) o ppc2list) met; - - -"pbltyp --- max_of_fun_on_interval ---"; -val pbltyp = {given=["function_term t","bound_variable v", - "domain {x::real. lower_bound <= x & x <= upper_bound}"], - where_=[], - find=["maximums ms"], - with_=["ALL m. m : ms --> \ - \ (ALL x::real. lower_bound <= x & x <= upper_bound \ - \ --> (%v. t) x <= m)"], - relate=[]}: string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val pbl = {given=["function_term #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \ - \ (#2*R*sin alpha)^^^#2","bound_variable alpha", - "domain {x::real. #0 <= x & x <= pi}"],where_=[], - find=["maximums [#1234]"],with_=[],relate=[]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - - -(* pbltyp --- max_of_fun --- *) -(* -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; -val (SOME ct) = parse thy ; -atomty thy (term_of ct); -*) - - - - - - - - -(* --- 14.1.00 --- *) -"p.114"; -val org = {given=["[u=(#12::real)]"],where_=[], - find=["[a,(b::real)]"],with_=[], - relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"p.116"; -val org = {given=["[c=#10, h=(#4::real)]"],where_=[], - find=["[x,(y::real)]"],with_=[], - relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"p.117"; -val org = {given=["[r=#5]"],where_=[], - find=["[x,(y::real)]"],with_=[], - relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"#241"; -val org = {given=["[s=(#10::real)]"],where_=[], - find=["[p::real]"],with_=[], - relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; - -(* -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; -val (SOME ct) = parse thy ; -atomty thy (term_of ct); -*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp-oldscr.sml --- a/src/Tools/isac/IsacKnowledge/DiffApp-oldscr.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -(*8.01: alte Scripts f"ur Extremwertaufgabe gesammelt*) - -(* Das erste Script aus dem Maximum-Beispiel. - parse erzeugt aus dem string 's' den - 'cterm 's' im Isabelle-Format (pretty-printing !)*) - -ML> ... -ML> val c = (the o (parse thy)) s; -val c = - "Script1 Maximum_value fix_ m_ rs_ v_ itv_ err_ = - let e_ = (hd o filter (Testvar m_)) rs_; - t_ = - if #1 < Length rs_ - then make_fun (R, [make, function], no_met) m_ v_ rs_ - else (Lhs o hd) rs_; - mx_ = - max_on_interval (R, [on_interval, max_of, function], - maximum_on_interval) t_ v_ itv_ - in find_vals (R, [find_values, tool], find_values) - mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm - -ML> set show_types; -ML> c; -val c = - "Script1 Maximum_value fix_::bool list m_::real rs_::bool list v_::real itv_::real set err_::bool = - let e_::bool = (hd o filter (Testvar m_)) rs_; - t_::real = - if (#1::real) < Length rs_ - then make_fun (R::ID, [make::ID, function::ID], no_met::ID) m_ v_ rs_ - else (Lhs o hd) rs_; - mx_::real = - max_on_interval (R, [on_interval::ID, max_of::ID, function], - maximum_on_interval::ID) t_ v_ itv_ - in find_vals (R, [find_values::ID, tool::ID], find_values) - mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm - - - -(* Die ersten 3 Scripts aus dem Maximum-Beispiel. - parse erzeugt aus dem string 's' den - 'cterm 's' im Isabelle-Format (pretty-printing !)*) - -ML> ... -ML> val c = (the o (parse thy)) s; -val c = - "Script maximum = - Input [Bool fix_, Real m_, BoolList rs_, Real v_, RealSet itv_, Bool err_] - Local [Bool e_, Real t_, Real mx_, RealList vs_] - Tacs [SEQU - [let e_ = (hd o filter (Testvar m_)) rs_ - in if #1 < Length rs_ - then Subproblem Spec (R, [make, function], no_met) - InOut [In m_, In v_, In rs_, Out t_] - else t_ := (Lhs o hd) rs_ ; - Subproblem Spec (R, [on_interval, max_of, function], - maximum_on_interval) - InOut [In t_, In v_, In itv_, In err_, Out mx_] ; - Subproblem Spec (R, [find_values, tool], find_values) - InOut [In mx_, In t_, In v_, In m_, In (dropWhile (op = e_) rs_), - Out vs_]]] - Return []" : cterm - -ML> ... -ML> val c = (the o (parse thy)) s; -val c = - "Script make_fun_by_new_variable = - Input [Real f_, Real v_, BoolList eqs_] - Local [Bool h_, BoolList es_, RealList vs_, Real v1_, Real v2_, Bool e1, - Bool e2_, BoolList s_1, BoolList s_2] - Tacs [SEQU - [let h_ = (hd o filter (Testvar m_)) eqs_; es_ = eqs_ -- [h_]; - vs_ = Var h_ -- [f_]; v1_ = Nth #1 vs_; v2_ = Nth #2 vs_; - e1_ = (hd o filter (Testvar v1_)) es_; - e2_ = (hd o filter (Testvar v2_)) es_ - in Subproblem Spec (R, [univar, equation], no_met) - InOut [In e1_, In v1_, Out s_1] ; - Subproblem Spec (R, [univar, equation], no_met) - InOut [In e2_, In v2_, Out s_2]], - Take (Bool h_) ; - Substitute [(v_1, (Rhs o hd) s_1), (v_2, (Rhs o hd) s_2)]] - Return [Currform]" : cterm - -ML> ... -ML> val c = (the o (parse thy)) s; -val c = - "Script make_fun_explicit = - Input [Real f_, Real v_, BoolList eqs_] - Local [Bool h_, Bool eq_, RealList vs_, Real v1_, BoolList ss_] - Tacs [SEQU - [let h_ = (hd o filter (Testvar m_)) eqs_; eq_ = hd (eqs_ -- [h_]); - vs_ = Var h_ -- [f_]; v1_ = hd (vs_ -- [v_]) - in Subproblem Spec (R, [univar, equation], no_met) - InOut [In eq_, In v1_, Out ss_]], - Take (Bool h_) ; Substitute [(v1_, (Rhs o hd) ss_)]] - Return [Currform]" : cterm -ML> diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp-scrpbl.sml --- a/src/Tools/isac/IsacKnowledge/DiffApp-scrpbl.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,429 +0,0 @@ -(* use"test-coil-kernel.sml"; - W.N.22.11.99 - -*) - -(* vvv--- geht nicht wegen fun-types -parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')"; -parse thy "if maxmin = is_max then (m' <= m) else (m <= m')"; -parse thy "if a=b then a else b"; -parse thy "maxmin = is_max"; -parse thy "maxmin =!= is_max"; - ^^^--- geht nicht wegen fun-types *) - -"pbltyp --- maximum ---"; -val pbltyp = {given=["fixedValues (cs::bool list)"], - where_=[(*"foldl (op &) True (map is_equality cs)", - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"*)], - find=["maximum m","values_for (ms::real list)"], - with_=[(*"Ex_frees ((foldl (op &) True (r#rs)) & \ - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \ - \ --> m' <= m)))"*)], - relate=["max_relation r","additionalRels rs"]}:string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val org = ["fixedValues [R=(R::real)]", - "boundVariable a","boundVariable b","boundVariable alpha", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= pi}", - "errorBound (eps = #1//#1000)", - "maximum A", - (*"max_relation A=#2*a*b - a^^^#2",*) - "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", - "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", - "relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"]; -val chkorg = map (the o (parse thy)) org; -val pbl = {given=["fixedValues [R=(R::real)]"],where_=[], - find=["maximum A","values_for [a,b]"], - with_=[(* incompat.w. parse, ok with parseold - "EX alpha. A=#2*a*b - a^^^#2 & \ - \ a=#2*R*sin alpha & b=#2*R*cos alpha & \ - \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha \ - \ & b=#2*R*cos alpha \ - \ --> A' <= A)"*)], - relate=["relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"] - }: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - -"met --- maximum_by_differentiation ---"; -val met = {given=["fixedValues (cs::bool list)","boundVariable v", - "domain {x::real. lower_bound <= x & x<=upper_bound}", - "errorBound epsilon"], - where_=[], - find=["maximum m","valuesFor (ms::bool list)", - "function_term t","max_argument mx"], - with_=[(* incompat.w. parse, ok with parseold - "Ex_frees ((foldl (op &) True (mr#ars)) & \ - \ (ALL m'. (subst (m,m') (foldl (op &) True (mr#ars))\ - \ --> m' <= m))) & \ - \m = (%v. t) mx & \ - \( ALL x. lower_bound <= x & x <= upper_bound \ - \ --> (%v. t) x <= m)"*)], - relate=["max_relation mr", - "additionalRels ars"]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) met; - -"data --- maximum_by_differentiation ---"; -val met = {given=["fixedValues [R=(R::real)]","boundVariable alpha", - "domain {x::real. #0 <= x & x <= pi//#2}", - "errorBound (eps = #1//#1000)"], - where_=[], - find=["maximum A","valuesFor [a=Undef]", - "function_term t","max_argument mx"], - with_=[(* incompat.w. parse, ok with parseold - "EX b alpha. A = #2*a*b - a^^^#2 & \ - \ a = #2*R*sin alpha & \ - \ b = #2*R*cos alpha & \ - \ (ALL A'. A'= #2*a*b - a^^^#2 & \ - \ a = #2*R*sin alpha & \ - \ b = #2*R*cos alpha --> A' <= A) & \ - \ A = (%alpha. t) mx & \ - \ (ALL x. #0 <= x & x <= pi --> \ - \ (%alpha. t) x <= A)"*)], - relate=["max_relation mr", - "additionalRels ars"]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) met; - -val (SOME ct) = parseold thy "EX b. (EX alpha. A = #2*a*b - a^^^#2)"; - -"pbltyp --- make_fun ---"; -(* subproblem [(hd #relate root, equality), - (boundVariable formalization, boundVariable), - (tl #relate root, equalities)] *) -val pbltyp = {given=["equality e","boundVariable v", "equalities es"], - where_=[], - find=["functionTerm t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val pbl = {given=["equality (A=#2*a*b - a^^^#2)","boundVariable alpha", - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], - where_=[], - find=["functionTerm t"], - with_=[],relate=[]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - -"met --- make_explicit_and_substitute ---"; -val met = {given=["equality e","boundVariable v", "equalities es"], - where_=[], - find=["functionTerm t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkmet = ((map (the o (parse thy))) o ppc2list) met; -"met --- introduce_a_new_variable ---"; -val met = {given=["equality e","boundVariable v", "substitutions es"], - where_=[], - find=["functionTerm t"],with_=[(*???*)], - relate=[(*???*)]}: string ppc; -val chkmet = ((map (the o (parse thy))) o ppc2list) met; - - -"pbltyp --- max_of_fun_on_interval ---"; -val pbltyp = {given=["functionTerm t","boundVariable v", - "domain {x::real. lower_bound <= x & x <= upper_bound}"], - where_=[], - find=["maximums ms"], - with_=[(* incompat.w. parse, ok with parseold - "ALL m. m : ms --> \ - \ (ALL x::real. lower_bound <= x & x <= upper_bound \ - \ --> (%v. t) x <= m)"*)], - relate=[]}: string ppc; -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; -"coil"; -val pbl = {given=["functionTerm (f = #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \ - \ (#2*R*sin alpha)^^^#2)","boundVariable alpha", - "domain {x::real. #0 <= x & x <= pi}"],where_=[], - find=["maximums [#1234]"],with_=[],relate=[]}: string ppc; -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; - - -(* pbltyp --- max_of_fun --- *) -(* -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; -val (SOME ct) = parse thy ; -atomty (term_of ct); -*) - - -(* --- 14.1.00 ev. nicht ganz up to date bzg. oberem --- *) -"p.114"; -val org = {given=["[u=(#12::real)]"],where_=[], - find=["[a,(b::real)]"],with_=[], - relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"p.116"; -val org = {given=["[c=#10, h=(#4::real)]"],where_=[], - find=["[x,(y::real)]"],with_=[], - relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"p.117"; -val org = {given=["[r=#5]"],where_=[], - find=["[x,(y::real)]"],with_=[], - relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; -"#241"; -val org = {given=["[s=(#10::real)]"],where_=[], - find=["[p::real]"],with_=[], - relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc; -val chkorg = ((map (the o (parse thy))) o ppc2list) org; - - - -(* -------------- coil-kernel -------------- vor 19.1.00 *) -(* --- subproblem: make-function-by-subst ~~~~~~~~~~~ *) -(* --- subproblem: max-of-function *) -(* --- subproblem: derivative *) -(* --- subproblem: tan-quadrat-equation *) -"-------------- coil-kernel --------------"; -val origin = ["A=#2*a*b - a^^^#2", - "a::real","b::real","{x. #0 real","maxs::real set"]; -val with_ = [(* incompat.w. parse, ok with parseold - "maxs = {m. low < m & m < high & \ - \ (m is_local_max_of (%bdv. f))}"*)]; -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_); -val givens = map (the o (parse thy)) given; - -"------- 1.1 -------"; -(* 5.3.00 -val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2", - "a::real","{x. #0 val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = - specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree; - -> val ct = "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2, b=#2*R*cos alpha]"; -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; -*) - -(* --- incomplete input --- -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = - specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree; - -> val ct = "[R=(R::real)]"; -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; - -> val ct = "R=(R::real)"; -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; - -> val ct = "(R::real)"; -> specify nxt p c pt; -*) - - -" #################################################### "; -" test do_ specify "; -" #################################################### "; - - -val cts = ["fixedValues [R=(R::real)]", - "boundVariable a", "boundVariable b", - "boundVariable alpha", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= #2*R}", - "domain {x::real. #0 <= x & x <= pi//#2}", - "errorBound (eps=#1//#1000)", - "maximum A","valuesFor [a=Undef]", - (*"functionTerm t","max_argument mx", *) - "max_relation (A=#2*a*b - a^^^#2)", - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]", - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]", - "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"]; -val (dI',pI',mI')= - ("DiffAppl.thy",["DiffAppl.thy","test_maximum"],e_metID); -val p = e_pos'; val c = []; - -val (mI,m) = ("Init_Proof",Init_Proof (cts, (dI',pI',mI'))); -val (pst as (sc,pt,cl):pstate) = (EmptyScr, e_ptree, []); -val (p,_,f,nxt,_,(_,pt,_)) = do_ (mI,m) p c pst; -(*val nxt = ("Add_Given",Add_Given "fixedValues [R = R]")*) - -val (p,_,Form' (PpcKF (_,_,ppc)),nxt,_,(_,pt,_)) = - do_ nxt p c (EmptyScr,pt,[]); -(*val nxt = ("Add_Given",Add_Given "boundVariable a") *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp.ML --- a/src/Tools/isac/IsacKnowledge/DiffApp.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,221 +0,0 @@ -(* tools for applications of differetiation - use"DiffApp.ML"; - use"IsacKnowledge/DiffApp.ML"; - use"../IsacKnowledge/DiffApp.ML"; - - -WN.6.5.03: old decisions in this file partially are being changed - in a quick-and-dirty way to make scripts run: Maximum_value, - Make_fun_by_new_variable, Make_fun_by_explicit. -found to be reconsidered: -- descriptions (Descript.thy) -- penv: really need term list; or just rerun the whole example with num/var -- mk_arg, itms2args ... env in script different from penv ? -- L = SubProblem eq ... show some vars on the worksheet ? (other means for - referencing are labels (no on worksheet)) - -WN.6.5.03 quick-and-dirty: mk_arg, itms2args just make most convenient env - from penv as is. - *) - - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("DiffApp.thy",DiffApp.thy)]); - -val eval_rls = prep_rls( - Rls {id="eval_rls",preconds = [], rew_ord = ("termlessI",termlessI), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - Thm ("and_commute",num_str and_commute), - Thm ("or_commute",num_str or_commute), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Tools.matches",eval_matches "") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -ruleset' := overwritelthy thy - (!ruleset', - [("eval_rls",Atools_erls)(*FIXXXME:del with rls.rls'*) - ]); - - -(** problem types **) - -store_pbt - (prep_pbt DiffApp.thy "pbl_fun_max" [] e_pblID - (["maximum_of","function"], - [("#Given" ,["fixedValues fix_"]), - ("#Find" ,["maximum m_","valuesFor vs_"]), - ("#Relate",["relations rs_"]) - ], - e_rls, NONE, [])); - -store_pbt - (prep_pbt DiffApp.thy "pbl_fun_make" [] e_pblID - (["make","function"]:pblID, - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), - ("#Find" ,["functionEq f_1_"]) - ], - e_rls, NONE, [])); -store_pbt - (prep_pbt DiffApp.thy "pbl_fun_max_expl" [] e_pblID - (["by_explicit","make","function"]:pblID, - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), - ("#Find" ,["functionEq f_1_"]) - ], - e_rls, NONE, [["DiffApp","make_fun_by_explicit"]])); -store_pbt - (prep_pbt DiffApp.thy "pbl_fun_max_newvar" [] e_pblID - (["by_new_variable","make","function"]:pblID, - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), - (*WN.12.5.03: precond for distinction still missing*) - ("#Find" ,["functionEq f_1_"]) - ], - e_rls, NONE, [["DiffApp","make_fun_by_new_variable"]])); - -store_pbt - (prep_pbt DiffApp.thy "pbl_fun_max_interv" [] e_pblID - (["on_interval","maximum_of","function"]:pblID, - [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"]), - (*WN.12.5.03: precond for distinction still missing*) - ("#Find" ,["maxArgument v_0_"]) - ], - e_rls, NONE, [])); - -store_pbt - (prep_pbt DiffApp.thy "pbl_tool" [] e_pblID - (["tool"]:pblID, - [], - e_rls, NONE, [])); - -store_pbt - (prep_pbt DiffApp.thy "pbl_tool_findvals" [] e_pblID - (["find_values","tool"]:pblID, - [("#Given" ,["maxArgument ma_","functionEq f_","boundVariable v_"]), - ("#Find" ,["valuesFor vls_"]), - ("#Relate",["additionalRels rs_"]) - ], - e_rls, NONE, [])); - - -(** methods, scripts not yet implemented **) - -store_met - (prep_met Diff.thy "met_diffapp" [] e_metID - (["DiffApp"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls = Atools_erls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); -store_met - (prep_met DiffApp.thy "met_diffapp_max" [] e_metID - (["DiffApp","max_by_calculus"]:metID, - [("#Given" ,["fixedValues fix_","maximum m_","relations rs_", - "boundVariable v_","interval itv_","errorBound err_"]), - ("#Find" ,["valuesFor vs_"]), - ("#Relate",[]) - ], - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls, - crls = eval_rls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, - "Script Maximum_value(fix_::bool list)(m_::real) (rs_::bool list)\ - \ (v_::real) (itv_::real set) (err_::bool) = \ - \ (let e_ = (hd o (filterVar m_)) rs_; \ - \ t_ = (if 1 < length_ rs_ \ - \ then (SubProblem (DiffApp_,[make,function],[no_met])\ - \ [real_ m_, real_ v_, bool_list_ rs_])\ - \ else (hd rs_)); \ - \ (mx_::real) = SubProblem(DiffApp_,[on_interval,maximum_of,function],\ - \ [DiffApp,max_on_interval_by_calculus])\ - \ [bool_ t_, real_ v_, real_set_ itv_]\ - \ in ((SubProblem (DiffApp_,[find_values,tool],[Isac,find_values]) \ - \ [real_ mx_, real_ (Rhs t_), real_ v_, real_ m_, \ - \ bool_list_ (dropWhile (ident e_) rs_)])::bool list))" - )); -store_met - (prep_met DiffApp.thy "met_diffapp_funnew" [] e_metID - (["DiffApp","make_fun_by_new_variable"]:metID, - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), - ("#Find" ,["functionEq f_1_"]) - ], - {rew_ord'="tless_true",rls'=eval_rls,srls=list_rls,prls=e_rls, - calc=[], crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)}, - "Script Make_fun_by_new_variable (f_::real) (v_::real) \ - \ (eqs_::bool list) = \ - \(let h_ = (hd o (filterVar f_)) eqs_; \ - \ es_ = dropWhile (ident h_) eqs_; \ - \ vs_ = dropWhile (ident f_) (Vars h_); \ - \ v_1 = nth_ 1 vs_; \ - \ v_2 = nth_ 2 vs_; \ - \ e_1 = (hd o (filterVar v_1)) es_; \ - \ e_2 = (hd o (filterVar v_2)) es_; \ - \ (s_1::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\ - \ [bool_ e_1, real_ v_1]);\ - \ (s_2::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\ - \ [bool_ e_2, real_ v_2])\ - \in Substitute [(v_1 = (rhs o hd) s_1),(v_2 = (rhs o hd) s_2)] h_)" -)); -store_met -(prep_met DiffApp.thy "met_diffapp_funexp" [] e_metID -(["DiffApp","make_fun_by_explicit"]:metID, - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), - ("#Find" ,["functionEq f_1_"]) - ], - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls, - crls = eval_rls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, - "Script Make_fun_by_explicit (f_::real) (v_::real) \ - \ (eqs_::bool list) = \ - \ (let h_ = (hd o (filterVar f_)) eqs_; \ - \ e_1 = hd (dropWhile (ident h_) eqs_); \ - \ vs_ = dropWhile (ident f_) (Vars h_); \ - \ v_1 = hd (dropWhile (ident v_) vs_); \ - \ (s_1::bool list)=(SubProblem(DiffApp_,[univariate,equation],[no_met])\ - \ [bool_ e_1, real_ v_1])\ - \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)" - )); -store_met - (prep_met DiffApp.thy "met_diffapp_max_oninterval" [] e_metID - (["DiffApp","max_on_interval_by_calculus"]:metID, - [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"(*, - "errorBound err_"*)]), - ("#Find" ,["maxArgument v_0_"]) - ], - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls, - crls = eval_rls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, - "empty_script" - )); -store_met - (prep_met DiffApp.thy "met_diffapp_findvals" [] e_metID - (["DiffApp","find_values"]:metID, - [], - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls, - crls = eval_rls, nrls=norm_Rational(*, - asm_rls=[],asm_thm=[]*)}, - "empty_script")); - -val list_rls = append_rls "list_rls" list_rls - [Thm ("filterVar_Const", num_str filterVar_Const), - Thm ("filterVar_Nil", num_str filterVar_Nil) - ]; -ruleset' := overwritelthy thy (!ruleset', - [("list_rls",list_rls) - ]); - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp.sml --- a/src/Tools/isac/IsacKnowledge/DiffApp.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -(* = DiffAppl.ML - +++ outcommented tests -*) - - -theory' := overwritel (!theory', [("DiffAppl.thy",DiffAppl.thy)]); - -(* -> get_pbt ["DiffAppl.thy","maximum_of","function"]; -> get_met ("Script.thy","max_on_interval_by_calculus"); -> !pbltypes; - *) -pbltypes:= overwritel (!pbltypes, -[ - prep_pbt DiffAppl.thy - (["DiffAppl.thy","maximum_of","function"], - [("#Given" ,"fixedValues fix_"), - ("#Find" ,"maximum m_"), - ("#Find" ,"valuesFor vs_"), - ("#Relate","relations rs_") (*, - ("#where" ,"foldl (op&) True (map (Not o ((op<=) #0) o Rhs) fix_)"), - ("#with" ,"Ex_frees ((foldl (op &) True rs_) & \ - \ (ALL m'. (subst (m_,m') (foldl (op &) True rs_) \ - \ --> m' <= m_)))") *) - ]), - - prep_pbt DiffAppl.thy - (["DiffAppl.thy","make","function"]:pblID, - [("#Given" ,"functionOf f_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"equalities eqs_"), - ("#Find" ,"functionTerm f_0_") - ]), - - prep_pbt DiffAppl.thy - (["DiffAppl.thy","on_interval","maximum_of","function"]:pblID, - [("#Given" ,"functionTerm t_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"interval itv_"), - ("#Find" ,"maxArgument v_0_") - ]), - - prep_pbt DiffAppl.thy - (["DiffAppl.thy","find_values","tool"]:pblID, - [("#Given" ,"maxArgument ma_"), - ("#Given" ,"functionTerm f_"), - ("#Given" ,"boundVariable v_"), - ("#Find" ,"valuesFor vls_"), - ("#Relate","additionalRels rs_") - ]) -]); - - -methods:= overwritel (!methods, -[ - (("DiffAppl.thy","max_by_calculus"):metID, - {ppc = prep_met DiffAppl.thy - [("#Given" ,"fixedValues fix_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"interval itv_"), - ("#Given" ,"errorBound err_"), - ("#Find" ,"maximum m_"), - ("#Find" ,"valuesFor vs_"), - ("#Relate","relations rs_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met), - - (("DiffAppl.thy","make_fun_by_new_variable"):metID, - {ppc = prep_met DiffAppl.thy - [("#Given" ,"functionOf f_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"equalities eqs_"), - ("#Find" ,"functionTerm f_0_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met), - - (("DiffAppl.thy","make_fun_by_explicit"):metID, - {ppc = prep_met DiffAppl.thy - [("#Given" ,"functionOf f_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"equalities eqs_"), - ("#Find" ,"functionTerm f_0_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met), - - (("DiffAppl.thy","max_on_interval_by_calculus"):metID, - {ppc = prep_met DiffAppl.thy - [("#Given" ,"functionTerm t_"), - ("#Given" ,"boundVariable v_"), - ("#Given" ,"interval itv_"), - ("#Given" ,"errorBound err_"), - ("#Find" ,"maxArgument v_0_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met), - - (("DiffAppl.thy","find_values"):metID, - {ppc = prep_met DiffAppl.thy - [], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met) -]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/DiffApp.thy --- a/src/Tools/isac/IsacKnowledge/DiffApp.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -(* application of differential calculus - use_thy_only"../IsacKnowledge/DiffApp"; - use_thy_only"DiffApp"; - - -*) - - -DiffApp = Diff + - -consts - - Maximum'_value - :: "[bool list,real,bool list,real,real set,bool,\ - \ bool list] => bool list" - ("((Script Maximum'_value (_ _ _ _ _ _ =))// (_))" 9) - - Make'_fun'_by'_new'_variable - :: "[real,real,bool list, \ - \ bool] => bool" - ("((Script Make'_fun'_by'_new'_variable (_ _ _ =))// \ - \(_))" 9) - Make'_fun'_by'_explicit - :: "[real,real,bool list, \ - \ bool] => bool" - ("((Script Make'_fun'_by'_explicit (_ _ _ =))// \ - \(_))" 9) - - dummy :: real - -(*for script Maximum_value*) - filterVar :: "[real, 'a list] => 'a list" - -(*primrec*)rules - filterVar_Nil "filterVar v [] = []" - filterVar_Const "filterVar v (x#xs) = \ - \(if (v mem (Vars x)) then x#(filterVar v xs) \ - \ else filterVar v xs) " - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/EqSystem.ML --- a/src/Tools/isac/IsacKnowledge/EqSystem.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,673 +0,0 @@ -(* tools for systems of equations over the reals - author: Walther Neuper 050905, 08:51 - (c) due to copyright terms - -use"IsacKnowledge/EqSystem.ML"; -use"EqSystem.ML"; - -remove_thy"EqSystem"; -use_thy"IsacKnowledge/Isac"; -*) - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("EqSystem.thy",EqSystem.thy)]); - -(** eval functions **) - -(*certain variables of a given list occur _all_ in a term - args: all: ..variables, which are under consideration (eg. the bound vars) - vs: variables which must be in t, - and none of the others in all must be in t - t: the term under consideration - *) -fun occur_exactly_in vs all t = - let fun occurs_in' a b = occurs_in b a - in foldl and_ (true, map (occurs_in' t) vs) - andalso not (foldl or_ (false, map (occurs_in' t) (all \\ vs))) - end; - -(*("occur_exactly_in", ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in "#eval_occur_exactly_in_"))*) -fun eval_occur_exactly_in _ "EqSystem.occur'_exactly'_in" - (p as (Const ("EqSystem.occur'_exactly'_in",_) - $ vs $ all $ t)) _ = - if occur_exactly_in (isalist2list vs) (isalist2list all) t - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_occur_exactly_in _ _ _ _ = NONE; - -calclist':= -overwritel (!calclist', - [("occur_exactly_in", - ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in "#eval_occur_exactly_in_")) - ]); - - -(** rewrite order 'ord_simplify_System' **) - -(* order wrt. several linear (i.e. without exponents) variables "c","c_2",.. - which leaves the monomials containing c, c_2,... at the end of an Integral - and puts the c, c_2,... rightmost within a monomial. - - WN050906 this is a quick and dirty adaption of ord_make_polynomial_in, - which was most adequate, because it uses size_of_term*) -(**) -local (*. for simplify_System .*) -(**) -open Term; (* for type order = EQUAL | LESS | GREATER *) - -fun pr_ord EQUAL = "EQUAL" - | pr_ord LESS = "LESS" - | pr_ord GREATER = "GREATER"; - -fun dest_hd' (Const (a, T)) = (((a, 0), T), 0) - | dest_hd' (Free (ccc, T)) = - (case explode ccc of - "c"::[] => ((("|||||||||||||||||||||", 0), T), 1)(*greatest string WN*) - | "c"::"_"::_ => ((("|||||||||||||||||||||", 0), T), 1) - | _ => (((ccc, 0), T), 1)) - | dest_hd' (Var v) = (v, 2) - | dest_hd' (Bound i) = ((("", i), dummyT), 3) - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); - -fun size_of_term' (Free (ccc, _)) = - (case explode ccc of (*WN0510 hack for the bound variables*) - "c"::[] => 1000 - | "c"::"_"::is => 1000 * ((str2int o implode) is) - | _ => 1) - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body - | size_of_term' (f$t) = size_of_term' f + size_of_term' t - | size_of_term' _ = 1; - -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) - | term_ord' pr thy (t, u) = - (if pr then - let - val (f, ts) = strip_comb t and (g, us) = strip_comb u; - val _=writeln("t= f@ts= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ - (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\""); - val _=writeln("u= g@us= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ - (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\""); - val _=writeln("size_of_term(t,u)= ("^ - (string_of_int(size_of_term' t))^", "^ - (string_of_int(size_of_term' u))^")"); - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); - val _=writeln("terms_ord(ts,us) = "^ - ((pr_ord o terms_ord str false)(ts,us))); - val _=writeln("-------"); - in () end - else (); - case int_ord (size_of_term' t, size_of_term' u) of - EQUAL => - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) - | ord => ord) - end - | ord => ord) -and hd_ord (f, g) = (* ~ term.ML *) - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, - dest_hd' g) -and terms_ord str pr (ts, us) = - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); -(**) -in -(**) -(*WN0510 for preliminary use in eval_order_system, see case-study mat-eng.tex -fun ord_simplify_System_rev (pr:bool) thy subst tu = - (term_ord' pr thy (Library.swap tu) = LESS);*) - -(*for the rls's*) -fun ord_simplify_System (pr:bool) thy subst tu = - (term_ord' pr thy tu = LESS); -(**) -end; -(**) -rew_ord' := overwritel (!rew_ord', -[("ord_simplify_System", ord_simplify_System false thy) - ]); - - -(** rulesets **) - -(*.adapted from 'order_add_mult_in' by just replacing the rew_ord.*) -val order_add_mult_System = - Rls{id = "order_add_mult_System", preconds = [], - rew_ord = ("ord_simplify_System", - ord_simplify_System false Integrate.thy), - erls = e_rls,srls = Erls, calc = [], - rules = [Thm ("real_mult_commute",num_str real_mult_commute), - (* z * w = w * z *) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) - Thm ("real_mult_assoc",num_str real_mult_assoc), - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) - Thm ("real_add_commute",num_str real_add_commute), - (*z + w = w + z*) - Thm ("real_add_left_commute",num_str real_add_left_commute), - (*x + (y + z) = y + (x + z)*) - Thm ("real_add_assoc",num_str real_add_assoc) - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) - ], - scr = EmptyScr}:rls; - -(*.adapted from 'norm_Rational' by - #1 using 'ord_simplify_System' in 'order_add_mult_System' - #2 NOT using common_nominator_p .*) -val norm_System_noadd_fractions = - Rls {id = "norm_System_noadd_fractions", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [(*sequence given by operator precedence*) - Rls_ discard_minus, - Rls_ powers, - Rls_ rat_mult_divide, - Rls_ expand, - Rls_ reduce_0_1_2, - Rls_ (*order_add_mult #1*) order_add_mult_System, - Rls_ collect_numerals, - (*Rls_ add_fractions_p, #2*) - Rls_ cancel_p - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; -(*.adapted from 'norm_Rational' by - *1* using 'ord_simplify_System' in 'order_add_mult_System'.*) -val norm_System = - Rls {id = "norm_System", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [(*sequence given by operator precedence*) - Rls_ discard_minus, - Rls_ powers, - Rls_ rat_mult_divide, - Rls_ expand, - Rls_ reduce_0_1_2, - Rls_ (*order_add_mult *1*) order_add_mult_System, - Rls_ collect_numerals, - Rls_ add_fractions_p, - Rls_ cancel_p - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -(*.simplify an equational system BEFORE solving it such that parentheses are - ( ((u0*v0)*w0) + ( ((u1*v1)*w1) * c + ... +((u4*v4)*w4) * c_4 ) ) -ATTENTION: works ONLY for bound variables c, c_1, c_2, c_3, c_4 :ATTENTION - This is a copy from 'make_ratpoly_in' with respective reductions: - *0* expand the term, ie. distribute * and / over + - *1* ord_simplify_System instead of termlessI - *2* no add_fractions_p (= common_nominator_p_rls !) - *3* discard_parentheses only for (.*(.*.)) - analoguous to simplify_Integral .*) -val simplify_System_parenthesized = - Seq {id = "simplify_System_parenthesized", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, calc = [], - rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib), - (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*) - Thm ("real_add_divide_distrib",num_str real_add_divide_distrib), - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*) - (*^^^^^ *0* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*) - Rls_ norm_Rational_noadd_fractions(**2**), - Rls_ (*order_add_mult_in*) norm_System_noadd_fractions (**1**), - Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)) - (*Rls_ discard_parentheses *3**), - Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*) - Rls_ separate_bdv2, - Calc ("HOL.divide" ,eval_cancel "#divide_") - ], - scr = EmptyScr}:rls; - -(*.simplify an equational system AFTER solving it; - This is a copy of 'make_ratpoly_in' with the differences - *1* ord_simplify_System instead of termlessI .*) -(*TODO.WN051031 ^^^^^^^^^^ should be in EACH rls contained *) -val simplify_System = - Seq {id = "simplify_System", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, calc = [], - rules = [Rls_ norm_Rational, - Rls_ (*order_add_mult_in*) norm_System (**1**), - Rls_ discard_parentheses, - Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*) - Rls_ separate_bdv2, - Calc ("HOL.divide" ,eval_cancel "#divide_") - ], - scr = EmptyScr}:rls; -(* -val simplify_System = - append_rls "simplify_System" simplify_System_parenthesized - [Thm ("sym_real_add_assoc", num_str (real_add_assoc RS sym))]; -*) - -val isolate_bdvs = - Rls {id="isolate_bdvs", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = append_rls "erls_isolate_bdvs" e_rls - [(Calc ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in - "#eval_occur_exactly_in_")) - ], - srls = Erls, calc = [], - rules = [Thm ("commute_0_equality", - num_str commute_0_equality), - Thm ("separate_bdvs_add", num_str separate_bdvs_add), - Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)], - scr = EmptyScr}; -val isolate_bdvs_4x4 = - Rls {id="isolate_bdvs_4x4", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = append_rls - "erls_isolate_bdvs_4x4" e_rls - [Calc ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in "#eval_occur_exactly_in_"), - Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Atools.some'_occur'_in", - eval_some_occur_in "#some_occur_in_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false) - ], - srls = Erls, calc = [], - rules = [Thm ("commute_0_equality", - num_str commute_0_equality), - Thm ("separate_bdvs0", num_str separate_bdvs0), - Thm ("separate_bdvs_add1", num_str separate_bdvs_add1), - Thm ("separate_bdvs_add1", num_str separate_bdvs_add2), - Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)], - scr = EmptyScr}; - -(*.order the equations in a system such, that a triangular system (if any) - appears as [..c_4 = .., ..., ..., ..c_1 + ..c_2 + ..c_3 ..c_4 = ..].*) -val order_system = - Rls {id="order_system", preconds = [], - rew_ord = ("ord_simplify_System", - ord_simplify_System false thy), - erls = Erls, srls = Erls, calc = [], - rules = [Thm ("order_system_NxN", num_str order_system_NxN) - ], - scr = EmptyScr}; - -val prls_triangular = - Rls {id="prls_triangular", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = Rls {id="erls_prls_triangular", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = Erls, srls = Erls, calc = [], - rules = [(*for precond nth_Cons_ ...*) - Calc ("op <",eval_equ "#less_"), - Calc ("op +", eval_binop "#add_") - (*immediately repeated rewrite pushes - '+' into precondition !*) - ], - scr = EmptyScr}, - srls = Erls, calc = [], - rules = [Thm ("nth_Cons_",num_str nth_Cons_), - Calc ("op +", eval_binop "#add_"), - Thm ("nth_Nil_",num_str nth_Nil_), - Thm ("tl_Cons",num_str tl_Cons), - Thm ("tl_Nil",num_str tl_Nil), - Calc ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in - "#eval_occur_exactly_in_") - ], - scr = EmptyScr}; - -(*WN060914 quickly created for 4x4; - more similarity to prls_triangular desirable*) -val prls_triangular4 = - Rls {id="prls_triangular4", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = Rls {id="erls_prls_triangular4", preconds = [], - rew_ord = ("e_rew_ord", e_rew_ord), - erls = Erls, srls = Erls, calc = [], - rules = [(*for precond nth_Cons_ ...*) - Calc ("op <",eval_equ "#less_"), - Calc ("op +", eval_binop "#add_") - (*immediately repeated rewrite pushes - '+' into precondition !*) - ], - scr = EmptyScr}, - srls = Erls, calc = [], - rules = [Thm ("nth_Cons_",num_str nth_Cons_), - Calc ("op +", eval_binop "#add_"), - Thm ("nth_Nil_",num_str nth_Nil_), - Thm ("tl_Cons",num_str tl_Cons), - Thm ("tl_Nil",num_str tl_Nil), - Calc ("EqSystem.occur'_exactly'_in", - eval_occur_exactly_in - "#eval_occur_exactly_in_") - ], - scr = EmptyScr}; - -ruleset' := -overwritelthy thy - (!ruleset', -[("simplify_System_parenthesized", prep_rls simplify_System_parenthesized), - ("simplify_System", prep_rls simplify_System), - ("isolate_bdvs", prep_rls isolate_bdvs), - ("isolate_bdvs_4x4", prep_rls isolate_bdvs_4x4), - ("order_system", prep_rls order_system), - ("order_add_mult_System", prep_rls order_add_mult_System), - ("norm_System_noadd_fractions", prep_rls norm_System_noadd_fractions), - ("norm_System", prep_rls norm_System) - ]); - - -(** problems **) - -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys" [] e_pblID - (["system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Find" ,["solution ss___"](*___ is copy-named*)) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "solveSystem es_ vs_", - [])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin" [] e_pblID - (["linear", "system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - (*TODO.WN050929 check linearity*) - ("#Find" ,["solution ss___"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "solveSystem es_ vs_", - [])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2" [] e_pblID - (["2x2", "linear", "system"], - (*~~~~~~~~~~~~~~~~~~~~~~~~~*) - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" ,["length_ (es_:: bool list) = 2", "length_ vs_ = 2"]), - ("#Find" ,["solution ss___"]) - ], - append_rls "prls_2x2_linear_system" e_rls - [Thm ("length_Cons_",num_str length_Cons_), - Thm ("length_Nil_",num_str length_Nil_), - Calc ("op +", eval_binop "#add_"), - Calc ("op =",eval_equal "#equal_") - ], - SOME "solveSystem es_ vs_", - [])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_tri" [] e_pblID - (["triangular", "2x2", "linear", "system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" , - ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))", - " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]), - ("#Find" ,["solution ss___"]) - ], - prls_triangular, - SOME "solveSystem es_ vs_", - [["EqSystem","top_down_substitution","2x2"]])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_norm" [] e_pblID - (["normalize", "2x2", "linear", "system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Find" ,["solution ss___"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "solveSystem es_ vs_", - [["EqSystem","normalize","2x2"]])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_3x3" [] e_pblID - (["3x3", "linear", "system"], - (*~~~~~~~~~~~~~~~~~~~~~~~~~*) - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" ,["length_ (es_:: bool list) = 3", "length_ vs_ = 3"]), - ("#Find" ,["solution ss___"]) - ], - append_rls "prls_3x3_linear_system" e_rls - [Thm ("length_Cons_",num_str length_Cons_), - Thm ("length_Nil_",num_str length_Nil_), - Calc ("op +", eval_binop "#add_"), - Calc ("op =",eval_equal "#equal_") - ], - SOME "solveSystem es_ vs_", - [])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4" [] e_pblID - (["4x4", "linear", "system"], - (*~~~~~~~~~~~~~~~~~~~~~~~~~*) - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" ,["length_ (es_:: bool list) = 4", "length_ vs_ = 4"]), - ("#Find" ,["solution ss___"]) - ], - append_rls "prls_4x4_linear_system" e_rls - [Thm ("length_Cons_",num_str length_Cons_), - Thm ("length_Nil_",num_str length_Nil_), - Calc ("op +", eval_binop "#add_"), - Calc ("op =",eval_equal "#equal_") - ], - SOME "solveSystem es_ vs_", - [])); -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_tri" [] e_pblID - (["triangular", "4x4", "linear", "system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" , (*accepts missing variables up to diagional form*) - ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))", - "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))", - "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))", - "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))" - ]), - ("#Find" ,["solution ss___"]) - ], - append_rls "prls_tri_4x4_lin_sys" prls_triangular - [Calc ("Atools.occurs'_in",eval_occurs_in "")], - SOME "solveSystem es_ vs_", - [["EqSystem","top_down_substitution","4x4"]])); - -store_pbt - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_norm" [] e_pblID - (["normalize", "4x4", "linear", "system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - (*length_ is checked 1 level above*) - ("#Find" ,["solution ss___"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "solveSystem es_ vs_", - [["EqSystem","normalize","4x4"]])); - - -(* show_ptyps(); - *) - -(** methods **) - -store_met - (prep_met EqSystem.thy "met_eqsys" [] e_metID - (["EqSystem"], - [], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, - "empty_script" - )); -store_met - (prep_met EqSystem.thy "met_eqsys_topdown" [] e_metID - (["EqSystem","top_down_substitution"], - [], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, - "empty_script" - )); -store_met - (prep_met EqSystem.thy "met_eqsys_topdown_2x2" [] e_metID - (["EqSystem","top_down_substitution","2x2"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" , - ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))", - " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]), - ("#Find" ,["solution ss___"]) - ], - {rew_ord'="ord_simplify_System", rls' = Erls, calc = [], - srls = append_rls "srls_top_down_2x2" e_rls - [Thm ("hd_thm",num_str hd_thm), - Thm ("tl_Cons",num_str tl_Cons), - Thm ("tl_Nil",num_str tl_Nil) - ], - prls = prls_triangular, crls = Erls, nrls = Erls}, -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ -\ (let e1__ = Take (hd es_); \ -\ e1__ = ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ isolate_bdvs False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System False))) e1__; \ -\ e2__ = Take (hd (tl es_)); \ -\ e2__ = ((Substitute [e1__]) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ isolate_bdvs False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System False))) e2__; \ -\ es__ = Take [e1__, e2__] \ -\ in (Try (Rewrite_Set order_system False)) es__)" -(*--------------------------------------------------------------------------- - this script does NOT separate the equations as abolve, - but it does not yet work due to preliminary script-interpreter, - see eqsystem.sml 'script [EqSystem,top_down_substitution,2x2] Vers.2' - -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ -\ (let es__ = Take es_; \ -\ e1__ = hd es__; \ -\ e2__ = hd (tl es__); \ -\ es__ = [e1__, Substitute [e1__] e2__] \ -\ in ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))] \ -\ isolate_bdvs False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System False))) es__)" ----------------------------------------------------------------------------*) - )); -store_met - (prep_met EqSystem.thy "met_eqsys_norm" [] e_metID - (["EqSystem","normalize"], - [], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, - "empty_script" - )); -store_met - (prep_met EqSystem.thy "met_eqsys_norm_2x2" [] e_metID - (["EqSystem","normalize","2x2"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Find" ,["solution ss___"])], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = append_rls "srls_normalize_2x2" e_rls - [Thm ("hd_thm",num_str hd_thm), - Thm ("tl_Cons",num_str tl_Cons), - Thm ("tl_Nil",num_str tl_Nil) - ], - prls = Erls, crls = Erls, nrls = Erls}, -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ -\ (let es__ = ((Try (Rewrite_Set norm_Rational False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ isolate_bdvs False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set order_system False))) es_ \ -\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \ -\ [bool_list_ es__, real_list_ vs_]))" - )); - -(*this is for nth_ only*) -val srls = Rls {id="srls_normalize_4x4", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls - [(*for asm in nth_Cons_ ...*) - Calc ("op <",eval_equ "#less_"), - (*2nd nth_Cons_ pushes n+-1 into asms*) - Calc("op +", eval_binop "#add_") - ], - srls = Erls, calc = [], - rules = [Thm ("nth_Cons_",num_str nth_Cons_), - Calc("op +", eval_binop "#add_"), - Thm ("nth_Nil_",num_str nth_Nil_)], - scr = EmptyScr}; -store_met - (prep_met EqSystem.thy "met_eqsys_norm_4x4" [] e_metID - (["EqSystem","normalize","4x4"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Find" ,["solution ss___"])], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = append_rls "srls_normalize_4x4" srls - [Thm ("hd_thm",num_str hd_thm), - Thm ("tl_Cons",num_str tl_Cons), - Thm ("tl_Nil",num_str tl_Nil) - ], - prls = Erls, crls = Erls, nrls = Erls}, -(*GOON met ["EqSystem","normalize","4x4"] @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ -\ (let es__ = \ -\ ((Try (Rewrite_Set norm_Rational False)) @@ \ -\ (Repeat (Rewrite commute_0_equality False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ -\ isolate_bdvs_4x4 False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set order_system False))) es_ \ -\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \ -\ [bool_list_ es__, real_list_ vs_]))" -)); -store_met -(prep_met EqSystem.thy "met_eqsys_topdown_4x4" [] e_metID - (["EqSystem","top_down_substitution","4x4"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Where" , (*accepts missing variables up to diagonal form*) - ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))", - "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))", - "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))", - "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))" - ]), - ("#Find" ,["solution ss___"]) - ], - {rew_ord'="ord_simplify_System", rls' = Erls, calc = [], - srls = append_rls "srls_top_down_4x4" srls [], - prls = append_rls "prls_tri_4x4_lin_sys" prls_triangular - [Calc ("Atools.occurs'_in",eval_occurs_in "")], - crls = Erls, nrls = Erls}, -(*FIXXXXME.WN060916: this script works ONLY for exp 7.79 @@@@@@@@@@@@@@@@@@@@*) -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ -\ (let e1_ = nth_ 1 es_; \ -\ e2_ = Take (nth_ 2 es_); \ -\ e2_ = ((Substitute [e1_]) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ -\ simplify_System_parenthesized False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ -\ isolate_bdvs False)) @@ \ -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ -\ norm_Rational False))) e2_ \ -\ in [e1_, e2_, nth_ 3 es_, nth_ 4 es_])" -)); - -(* show_mets(); - *) - -(* -use"IsacKnowledge/EqSystem.ML"; -use"EqSystem.ML"; -*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/EqSystem.thy --- a/src/Tools/isac/IsacKnowledge/EqSystem.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -(* equational systems, minimal -- for use in Biegelinie - author: Walther Neuper - 050826, - (c) due to copyright terms - -remove_thy"EqSystem"; -use_thy"IsacKnowledge/EqSystem"; - -use_thy_only"IsacKnowledge/EqSystem"; - -remove_thy"Typefix"; -use_thy"IsacKnowledge/Isac"; -*) - -EqSystem = Rational + Root + - -consts - - occur'_exactly'_in :: - "[real list, real list, 'a] => bool" ("_ from'_ _ occur'_exactly'_in _") - - (*descriptions in the related problems*) - solveForVars :: real list => toreall - solution :: bool list => toreall - - (*the CAS-command, eg. "solveSystem [x+y=1,y=2] [x,y]"*) - solveSystem :: "[bool list, real list] => bool list" - - (*Script-names*) - SolveSystemScript :: "[bool list, real list, bool list] \ - \=> bool list" - ("((Script SolveSystemScript (_ _ =))// (_))" 9) - -rules -(*stated as axioms, todo: prove as theorems - 'bdv' is a constant handled on the meta-level - specifically as a 'bound variable' *) - - commute_0_equality "(0 = a) = (a = 0)" - - (*WN0510 see simliar rules 'isolate_' 'separate_' (by RL) - [bdv_1,bdv_2,bdv_3,bdv_4] work also for 2 and 3 bdvs, ugly !*) - separate_bdvs_add - "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a |]\ - \ ==> (a + b = c) = (b = c + -1*a)" - separate_bdvs0 - "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in b; Not (b=!=0) |]\ - \ ==> (a = b) = (a + -1*b = 0)" - separate_bdvs_add1 - "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in c |]\ - \ ==> (a = b + c) = (a + -1*c = b)" - separate_bdvs_add2 - "[| Not (some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in a) |]\ - \ ==> (a + b = c) = (b = -1*a + c)" - - - - separate_bdvs_mult - "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a; Not (a=!=0) |]\ - \ ==>(a * b = c) = (b = c / a)" - - (*requires rew_ord for termination, eg. ord_simplify_Integral; - works for lists of any length, interestingly !?!*) - order_system_NxN "[a,b] = [b,a]" - -(* -remove_thy"EqSystem"; -use_thy_only"IsacKnowledge/EqSystem"; -use_thy"IsacKnowledge/EqSystem"; -use"IsacKnowledge/EqSystem.ML"; - *) -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Equation.ML --- a/src/Tools/isac/IsacKnowledge/Equation.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,85 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* defines equation and univariate-equation - created by: rlang - date: 02.09 - changed by: rlang - last change by: rlang - date: 02.11.29 -*) - -(* use_thy_only"IsacKnowledge/Equation"; - use_thy"IsacKnowledge/Equation"; - use"IsacKnowledge/Equation.ML"; - use"Equation.ML"; - *) - -theory' := overwritel (!theory', [("Equation.thy",Equation.thy)]); - -val univariate_equation_prls = - append_rls "univariate_equation_prls" e_rls - [Calc ("Tools.matches",eval_matches "")]; -ruleset' := -overwritelthy thy (!ruleset', - [("univariate_equation_prls", - prep_rls univariate_equation_prls)]); - - -store_pbt - (prep_pbt Equation.thy "pbl_equ" [] e_pblID - (["equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - append_rls "equation_prls" e_rls - [Calc ("Tools.matches",eval_matches "")], - SOME "solve (e_::bool, v_)", - [])); - -store_pbt - (prep_pbt Equation.thy "pbl_equ_univ" [] e_pblID - (["univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - univariate_equation_prls,SOME "solve (e_::bool, v_)",[])); - - -(*.function for handling the cas-input "solve (x+1=2, x)": - make a model which is already in ptree-internal format.*) -(* val (h,argl) = strip_comb (str2term "solve (x+1=2, x)"); - val (h,argl) = strip_comb ((term_of o the o (parse thy)) - "solveTest (x+1=2, x)"); - *) -fun argl2dtss [Const ("Pair", _) $ eq $ bdv] = - [((term_of o the o (parse thy)) "equality", [eq]), - ((term_of o the o (parse thy)) "solveFor", [bdv]), - ((term_of o the o (parse thy)) "solutions", - [(term_of o the o (parse thy)) "L"]) - ] - | argl2dtss _ = raise error "Equation.ML: wrong argument for argl2dtss"; - -castab := -overwritel (!castab, - [((term_of o the o (parse thy)) "solveTest", - (("Test.thy", ["univariate","equation","test"], ["no_met"]), - argl2dtss)), - ((term_of o the o (parse thy)) "solve", - (("Isac.thy", ["univariate","equation"], ["no_met"]), - argl2dtss)) - ]); - - - -store_met - (prep_met Equation.thy "met_equ" [] e_metID - (["Equation"], - [], - {rew_ord'="tless_true", rls'=Erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"empty_script" -)); - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Equation.thy --- a/src/Tools/isac/IsacKnowledge/Equation.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -(* equations and functions; functions NOT as lambda-terms - author: Walther Neuper 2005, 2006 - (c) due to copyright terms - -remove_thy"Equation"; -use_thy"IsacKnowledge/Equation"; -use_thy_only"IsacKnowledge/Equation"; - -remove_thy"Equation"; -use_thy"IsacKnowledge/Isac"; -*) - -Equation = Atools + - -consts - - (*descriptions in the related problems TODOshift here from Descriptions.thy*) - substitution :: bool => una - - (*the CAS-commands*) - solve :: "[bool * 'a] => bool list" (* solve (x+1=2, x) *) - solveTest :: "[bool * 'a] => bool list" (* for test collection *) - - (*Script-names*) - Function2Equality :: "[bool, bool, bool] \ - \=> bool" - ("((Script Function2Equality (_ _ =))// (_))" 9) - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/InsSort.ML --- a/src/Tools/isac/IsacKnowledge/InsSort.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -(* 6.8.02 change to Isabelle2002 caused error -- thy excluded ! - -Proving equations for primrec function(s) "InsSort.foldr" ... -GC #1.17.30.54.345.21479: (10 ms) -*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list" -*** imposes additional sort constraints on the declared type of the constant -*** The error(s) above occurred in definition "InsSort.ins.ins_list_def" -*) - -(* tools for insertion sort - use"IsacKnowledge/InsSort.ML"; -*) - -(** interface isabelle -- isac **) - -theory' := (!theory') @ [("InsSort.thy",InsSort.thy)]; - -(** rule set **) - -val ins_sort = prep_rls( - Rls{preconds = [], rew_ord = ("tless_true",tless_true), - rules = [Thm ("foldr_base",(*num_str*) foldr_base), - Thm ("foldr_rec",foldr_rec), - Thm ("ins_base",ins_base), - Thm ("ins_rec",ins_rec), - Thm ("sort_def",sort_def), - - Calc ("op <",eval_equ "#less_"), - Thm ("if_True", if_True), - Thm ("if_False", if_False) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); - -(** problem type **) - -store_pbt - (prep_pbt InsSort.thy - (["functional"]:pblID, - [("#Given" ,["unsorted u_"]), - ("#Find" ,["sorted s_"]) - ], - [])); - -store_pbt - (prep_pbt InsSort.thy - (["inssort","functional"]:pblID, - [("#Given" ,["unsorted u_"]), - ("#Find" ,["sorted s_"]) - ], - [])); - -(** method, - todo: implementation needs extra object-level lists **) - -store_met - (prep_met Diff.thy - (["InsSort"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls = Atools_rls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); -store_met - (prep_met InsSort.thy (*test-version for [#1,#3,#2] only: see *.sml*) - (["InsSort""sort"]:metID, - [("#Given" ,["unsorted u_"]), - ("#Find" ,["sorted s_"]) - ], - {rew_ord'="tless_true",rls'=eval_rls,calc = [], srls = e_rls, prls=e_rls, - crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)}, - "Script Sort (u_::'a list) = (Rewrite_Set ins_sort False) u_" - )); - -ruleset' := overwritelthy thy (!ruleset', - [(*("ins_sort",ins_sort) overwrites a Isa fun!!*) - ]:(string * rls) list); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/InsSort.sml --- a/src/Tools/isac/IsacKnowledge/InsSort.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,395 +0,0 @@ - - -(*-------------------------from InsSort.thy 8.3.01----------------------*) -(*List.thy: - foldl :: [['b,'a] => 'b, 'b, 'a list] => 'b -primrec - foldl_Nil "foldl f a [] = a" - foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs" - -above in sml: -fun foldr f [] a = a - | foldr f (x::xs) a = foldr f xs (f a x); -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); -fun sort xs = foldr ins xs []; -*) -(*-------------------------from InsSort.thy 8.3.01----------------------*) - - -(*-------------------------from InsSort.ML 8.3.01----------------------*) - -theory' := (!theory') @ [("InsSort.thy",InsSort.thy)]; - -val ins_sort = - Rls{preconds = [], rew_ord = ("tless_true",tless_true), - rules = [Thm ("foldr_base",(*num_str*) foldr_base), - Thm ("foldr_rec",foldr_rec), - Thm ("ins_base",ins_base), - Thm ("ins_rec",ins_rec), - Thm ("sort_def",sort_def), - - Calc ("op <",eval_equ "#less_"), - Thm ("if_True", if_True), - Thm ("if_False", if_False) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - - - - -(* -> get_pbt ["Script.thy","squareroot","univariate","equation"]; -> get_met ("Script.thy","max_on_interval_by_calculus"); -*) -pbltypes:= (!pbltypes) @ -[ - prep_pbt InsSort.thy - (["InsSort.thy","inssort"]:pblID, - [("#Given" ,"unsorted u_"), - ("#Find" ,"sorted s_") - ]) -]; - -methods:= (!methods) @ -[ -(*, -------17.6.00, - (("InsSort.thy","inssort"):metID, - {ppc = prep_met - [("#Given" ,"unsorted u_"), - ("#Find" ,"sorted s_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=Script (((inst_abs (assoc_thm "InsSort.thy")) - o term_of o the o (parse thy)) (*for [#1,#3,#2] only*) - "Script Ins_sort (u_::'a list) = \ - \ (let u_ = Rewrite sort_def False u_; \ - \ u_ = Rewrite foldr_rec False u_; \ - \ u_ = Rewrite ins_base False u_; \ - \ u_ = Rewrite foldr_rec False u_; \ - \ u_ = Rewrite ins_rec False u_; \ - \ u_ = Calculate le u_; \ - \ u_ = Rewrite if_True False u_; \ - \ u_ = Rewrite ins_base False u_; \ - \ u_ = Rewrite foldr_rec False u_; \ - \ u_ = Rewrite ins_rec False u_; \ - \ u_ = Calculate le u_; \ - \ u_ = Rewrite if_True False u_; \ - \ u_ = Rewrite ins_rec False u_; \ - \ u_ = Calculate le u_; \ - \ u_ = Rewrite if_False False u_; \ - \ u_ = Rewrite foldr_base False u_ \ - \ in u_)") - } : met), - - (("InsSort.thy","sort"):metID, - {ppc = prep_met - [("#Given" ,"unsorted u_"), - ("#Find" ,"sorted s_") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=Script ((inst_abs o term_of o the o (parse thy)) - "Script Sort (u_::'a list) = \ - \ Rewrite_Set ins_sort False u_") - } : met) -------- *) -(*, - - (("",""):metID, - {ppc = prep_met - [("#Given" ,""), - ("#Find" ,""), - ("#Relate","") - ], - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], - scr=EmptyScr} : met), -*) -]; -(*-------------------------from InsSort.ML 8.3.01----------------------*) - - -(*------------------------- nipkow ----------------------*) -consts - sort :: 'a list => 'a list - ins :: ['a,'a list] => 'a list -(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a -*) -rules - ins_base "ins e [] = [e]" - ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))" - -rules - sort_def "sort ls = (foldl ins ls [])" -end - - -(** swp: ..L **) -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) -fun foldL f [] e = e - | foldL f (l::ls) e = f(l,foldL f ls e); - -(* fn : int * int list -> int list *) -fun insL (e,[]) = [e] - | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls); - -fun sortL ls = foldL insL ls []; - -sortL [2,3,1]; (* [1,2,3] *) - - -(** swp, curried: ..LC **) -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) -fun foldLC f [] e = e - | foldLC f (x::xs) e = f x (foldLC f xs e); - -(* fn : int * int list -> int list *) -fun insLC e [] = [e] - | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls); - -fun sortLC ls = foldLC insLC ls []; - -sortLC [2,3,1]; (* [1,2,3] *) - - -(** sml110: ..l **) -(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *) -foldl; -(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!! -fun foldl f e [] = e - | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0 - -foldl op+ (0,[100,11,1]); -val it = 0 : int ... GEHT NICHT !!! *) - -fun insl (e,[]) = [e] - | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls); - -fun sortl ls = foldl insl [] ls; - -sortl [2,3,1]; (* [1,2,3] *) - - -(** sml110, curried: ..lC **) -(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *) -fun foldlC f e [] = e - | foldlC f e (l::ls) = f e (foldlC f e ls); - -(* fn : int -> int list -> int list *) -fun inslC e [] = [e] - | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls); - -fun sortlC ls = foldlC inslC [] ls; - -sortlC [2,3,1]; - -(*--- 15.6.00 ---*) - - -fun Foldl f a [] = a - | Foldl f a (x::xs) = Foldl f (f a x) xs; -(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*) - -fun add a b = a+b:int; - -Foldl add 0 [1,2,3]; - -fun ins0 a [] = [a] - | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs); -(*val ins = fn : int -> int list -> int list*) - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); -(*val ins = fn : int -> int list -> int list*) - -ins 3 [1,2,4]; - -fun sort xs = Foldl ins0 xs []; -(*operator domain: int -> int list -> int - operand: int -> int list -> int list - in expression: - Foldl ins - *) -fun sort xs = Foldl ins xs []; - - - -(*--- 17.6.00 ---*) - - -fun foldr f [] a = a - | foldr f (x::xs) a = foldr f xs (f a x); -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) - -fun add a b = a+b:int; - -fold add [1,2,3] 0; - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); -(*val ins = fn : int list -> int -> int list*) - -ins [1,2,4] 3; - -fun sort xs = foldr ins xs []; - -sort [3,1,4,2]; - - - -(*--- 17.6.00 II ---*) - -fun foldl f a [] = a - | foldl f a (x::xs) = foldl f (f a x) xs; - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); - -fun sort xs = foldl ins xs []; - -sort [3,1,4,2]; -(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*) - -(*------------------------- nipkow ----------------------*) -consts - sort :: 'a list => 'a list - ins :: ['a,'a list] => 'a list -(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a -*) -rules - ins_base "ins e [] = [e]" - ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))" - -rules - sort_def "sort ls = (foldl ins ls [])" -end - - -(** swp: ..L **) -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) -fun foldL f [] e = e - | foldL f (l::ls) e = f(l,foldL f ls e); - -(* fn : int * int list -> int list *) -fun insL (e,[]) = [e] - | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls); - -fun sortL ls = foldL insL ls []; - -sortL [2,3,1]; (* [1,2,3] *) - - -(** swp, curried: ..LC **) -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) -fun foldLC f [] e = e - | foldLC f (x::xs) e = f x (foldLC f xs e); - -(* fn : int * int list -> int list *) -fun insLC e [] = [e] - | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls); - -fun sortLC ls = foldLC insLC ls []; - -sortLC [2,3,1]; (* [1,2,3] *) - - -(** sml110: ..l **) -(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *) -foldl; -(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!! -fun foldl f e [] = e - | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0 - -foldl op+ (0,[100,11,1]); -val it = 0 : int ... GEHT NICHT !!! *) - -fun insl (e,[]) = [e] - | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls); - -fun sortl ls = foldl insl [] ls; - -sortl [2,3,1]; (* [1,2,3] *) - - -(** sml110, curried: ..lC **) -(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *) -fun foldlC f e [] = e - | foldlC f e (l::ls) = f e (foldlC f e ls); - -(* fn : int -> int list -> int list *) -fun inslC e [] = [e] - | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls); - -fun sortlC ls = foldlC inslC [] ls; - -sortlC [2,3,1]; - -(*--- 15.6.00 ---*) - - -fun Foldl f a [] = a - | Foldl f a (x::xs) = Foldl f (f a x) xs; -(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*) - -fun add a b = a+b:int; - -Foldl add 0 [1,2,3]; - -fun ins0 a [] = [a] - | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs); -(*val ins = fn : int -> int list -> int list*) - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); -(*val ins = fn : int -> int list -> int list*) - -ins 3 [1,2,4]; - -fun sort xs = Foldl ins0 xs []; -(*operator domain: int -> int list -> int - operand: int -> int list -> int list - in expression: - Foldl ins - *) -fun sort xs = Foldl ins xs []; - - - -(*--- 17.6.00 ---*) - - -fun foldr f [] a = a - | foldr f (x::xs) a = foldr f xs (f a x); -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) - -fun add a b = a+b:int; - -fold add [1,2,3] 0; - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); -(*val ins = fn : int list -> int -> int list*) - -ins [1,2,4] 3; - -fun sort xs = foldr ins xs []; - -sort [3,1,4,2]; - - - -(*--- 17.6.00 II ---*) - -fun foldl f a [] = a - | foldl f a (x::xs) = foldl f (f a x) xs; - -fun ins [] a = [a] - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); - -fun sort xs = foldl ins xs []; - -sort [3,1,4,2]; -(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*) -(*------------------------- nipkow ----------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/InsSort.thy --- a/src/Tools/isac/IsacKnowledge/InsSort.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -(* 6.8.02 change to Isabelle2002 caused error -- thy excluded ! - -Proving equations for primrec function(s) "InsSort.foldr" ... -GC #1.17.30.54.345.21479: (10 ms) -*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list" -*** imposes additional sort constraints on the declared type of the constant -*** The error(s) above occurred in definition "InsSort.ins.ins_list_def (@@@)" -*) - -(* insertion sort, would need lists different from script-lists WN.11.00 -WN.7.5.03: -"- started with someList :: 'a list => unl, fun dest_list -WN.8.5.03: error (@@@) remained with outcommenting foldr ?!? - - use_thy_only"IsacKnowledge/InsSort"; - -*) - -InsSort = Script + - -consts - -(*foldr :: [['a,'b] => 'a, 'b list, 'a] => 'a -WN.8.5.03: already defined in Isabelle2002 (instantiated by Typefix): - "[[real, real] => real, real list, real] => real") : term - - val t = str2term "foldr"; -val t = - Const - ("List.foldr", - "[[RealDef.real, RealDef.real] => RealDef.real, RealDef.real List.list, - RealDef.real] => RealDef.real") : term - *) - ins :: ['a list,'a] => 'a list - sort :: 'a list => 'a list - -(*descriptions, script-id*) - unsorted :: 'a list => unl - sorted :: 'a list => unl - -(*subproblem and script-name*) - Ins'_sort :: "['a list, \ - \ 'a list] => 'a list" - ("((Script Ins'_sort (_ =))// \ - \ (_))" 9) - Sort :: "['a list, \ - \ 'a list] => 'a list" - ("((Script Sort (_ =))// \ - \ (_))" 9) - -(*primrec - foldr_base "foldr f [] a = a" - foldr_rec "foldr f (x#xs) a = foldr f xs (f a x)" -*) - -rules - -(*primrec .. outcommented analoguous to ListG.thy*) - ins_base "ins [] a = [a]" - ins_rec "ins (x#xs) a = (if x < a then x#(ins xs a) else a#(x#xs))" - - sort_def "sort ls = foldr ins ls []" - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Integrate.ML --- a/src/Tools/isac/IsacKnowledge/Integrate.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,357 +0,0 @@ -(* tools for integration over the reals - author: Walther Neuper 050905, 08:51 - (c) due to copyright terms - -use"IsacKnowledge/Integrate.ML"; -use"Integrate.ML"; - -remove_thy"Integrate"; -use_thy"IsacKnowledge/Isac"; -*) - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("Integrate.thy",Integrate.thy)]); - -(** eval functions **) - -val c = Free ("c", HOLogic.realT); -(*.create a new unique variable 'c..' in a term; for use by Calc in a rls; - an alternative to do this would be '(Try (Calculate new_c_) (new_c es__))' - in the script; this will be possible if currying doesnt take the value - from a variable, but the value '(new_c es__)' itself.*) -fun new_c term = - let fun selc var = - case (explode o id_of) var of - "c"::[] => true - | "c"::"_"::is => (case (int_of_str o implode) is of - SOME _ => true - | NONE => false) - | _ => false; - fun get_coeff c = case (explode o id_of) c of - "c"::"_"::is => (the o int_of_str o implode) is - | _ => 0; - val cs = filter selc (vars term); - in - case cs of - [] => c - | [c] => Free ("c_2", HOLogic.realT) - | cs => - let val max_coeff = maxl (map get_coeff cs) - in Free ("c_"^string_of_int (max_coeff + 1), HOLogic.realT) end - end; - -(*WN080222 -(*("new_c", ("Integrate.new'_c", eval_new_c "#new_c_"))*) -fun eval_new_c _ _ (p as (Const ("Integrate.new'_c",_) $ t)) _ = - SOME ((term2str p) ^ " = " ^ term2str (new_c p), - Trueprop $ (mk_equality (p, new_c p))) - | eval_new_c _ _ _ _ = NONE; -*) - -(*WN080222:*) -(*("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "#add_new_c_")) - add a new c to a term or a fun-equation; - this is _not in_ the term, because only applied to _whole_ term*) -fun eval_add_new_c (_:string) "Integrate.add'_new'_c" p (_:theory) = - let val p' = case p of - Const ("op =", T) $ lh $ rh => - Const ("op =", T) $ lh $ mk_add rh (new_c rh) - | p => mk_add p (new_c p) - in SOME ((term2str p) ^ " = " ^ term2str p', - Trueprop $ (mk_equality (p, p'))) - end - | eval_add_new_c _ _ _ _ = NONE; - - -(*("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_x_"))*) -fun eval_is_f_x _ _(p as (Const ("Integrate.is'_f'_x", _) - $ arg)) _ = - if is_f_x arg - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_f_x _ _ _ _ = NONE; - -calclist':= overwritel (!calclist', - [(*("new_c", ("Integrate.new'_c", eval_new_c "new_c_")),*) - ("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_")), - ("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_idextifier_")) - ]); - - -(** rulesets **) - -(*.rulesets for integration.*) -val integration_rules = - Rls {id="integration_rules", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Rls {id="conditions_in_integration_rules", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Erls, - srls = Erls, calc = [], - rules = [(*for rewriting conditions in Thm's*) - Calc ("Atools.occurs'_in", - eval_occurs_in "#occurs_in_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",not_false) - ], - scr = EmptyScr}, - srls = Erls, calc = [], - rules = [ - Thm ("integral_const",num_str integral_const), - Thm ("integral_var",num_str integral_var), - Thm ("integral_add",num_str integral_add), - Thm ("integral_mult",num_str integral_mult), - Thm ("integral_pow",num_str integral_pow), - Calc ("op +", eval_binop "#add_")(*for n+1*) - ], - scr = EmptyScr}; -val add_new_c = - Seq {id="add_new_c", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Rls {id="conditions_in_add_new_c", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Erls, - srls = Erls, calc = [], - rules = [Calc ("Tools.matches", eval_matches""), - Calc ("Integrate.is'_f'_x", - eval_is_f_x "is_f_x_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false) - ], - scr = EmptyScr}, - srls = Erls, calc = [], - rules = [ (*Thm ("call_for_new_c", num_str call_for_new_c),*) - Cal1 ("Integrate.add'_new'_c", eval_add_new_c "new_c_") - ], - scr = EmptyScr}; - -(*.rulesets for simplifying Integrals.*) - -(*.for simplify_Integral adapted from 'norm_Rational_rls'.*) -val norm_Rational_rls_noadd_fractions = -Rls {id = "norm_Rational_rls_noadd_fractions", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [(*Rls_ common_nominator_p_rls,!!!*) - Rls_ (*rat_mult_div_pow original corrected WN051028*) - (Rls {id = "rat_mult_div_pow", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = (*FIXME.WN051028 e_rls,*) - append_rls "e_rls-is_polyexp" e_rls - [Calc ("Poly.is'_polyexp", - eval_is_polyexp "")], - srls = Erls, calc = [], - rules = [Thm ("rat_mult",num_str rat_mult), - (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) - Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r), - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) - - Thm ("real_divide_divide1_mg", real_divide_divide1_mg), - (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*) - Thm ("real_divide_divide1_eq", real_divide_divide1_eq), - (*"?x / (?y / ?z) = ?x * ?z / ?y"*) - Thm ("real_divide_divide2_eq", real_divide_divide2_eq), - (*"?x / ?y / ?z = ?x / (?y * ?z)"*) - Calc ("HOL.divide" ,eval_cancel "#divide_"), - - Thm ("rat_power", num_str rat_power) - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }), - Rls_ make_rat_poly_with_parentheses, - Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*) - Rls_ rat_reduce_1 - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls; - -(*.for simplify_Integral adapted from 'norm_Rational'.*) -val norm_Rational_noadd_fractions = - Seq {id = "norm_Rational_noadd_fractions", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [Rls_ discard_minus_, - Rls_ rat_mult_poly,(* removes double fractions like a/b/c *) - Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*) - Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*) - Rls_ norm_Rational_rls_noadd_fractions,(* the main rls (#) *) - Rls_ discard_parentheses_ (* mult only *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls; - -(*.simplify terms before and after Integration such that - ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO - common denominator as done by norm_Rational or make_ratpoly_in. - This is a copy from 'make_ratpoly_in' with respective reduction of rules and - *1* expand the term, ie. distribute * and / over + -.*) -val separate_bdv2 = - append_rls "separate_bdv2" - collect_bdv - [Thm ("separate_bdv", num_str separate_bdv), - (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) - Thm ("separate_bdv_n", num_str separate_bdv_n), - Thm ("separate_1_bdv", num_str separate_1_bdv), - (*"?bdv / ?b = (1 / ?b) * ?bdv"*) - Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*, - (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) - *****Thm ("real_add_divide_distrib", - *****num_str real_add_divide_distrib) - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)----------*) - ]; -val simplify_Integral = - Seq {id = "simplify_Integral", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [], (*asm_thm = [],*) - rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib), - (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*) - Thm ("real_add_divide_distrib",num_str real_add_divide_distrib), - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*) - (*^^^^^ *1* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*) - Rls_ norm_Rational_noadd_fractions, - Rls_ order_add_mult_in, - Rls_ discard_parentheses, - (*Rls_ collect_bdv, from make_polynomial_in*) - Rls_ separate_bdv2, - Calc ("HOL.divide" ,eval_cancel "#divide_") - ], - scr = EmptyScr}:rls; - - -(*simplify terms before and after Integration such that - ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO - common denominator as done by norm_Rational or make_ratpoly_in. - This is a copy from 'make_polynomial_in' with insertions from - 'make_ratpoly_in' -THIS IS KEPT FOR COMPARISON ............................................ -* val simplify_Integral = prep_rls( -* Seq {id = "", preconds = []:term list, -* rew_ord = ("dummy_ord", dummy_ord), -* erls = Atools_erls, srls = Erls, -* calc = [], (*asm_thm = [],*) -* rules = [Rls_ expand_poly, -* Rls_ order_add_mult_in, -* Rls_ simplify_power, -* Rls_ collect_numerals, -* Rls_ reduce_012, -* Thm ("realpow_oneI",num_str realpow_oneI), -* Rls_ discard_parentheses, -* Rls_ collect_bdv, -* (*below inserted from 'make_ratpoly_in'*) -* Rls_ (append_rls "separate_bdv" -* collect_bdv -* [Thm ("separate_bdv", num_str separate_bdv), -* (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) -* Thm ("separate_bdv_n", num_str separate_bdv_n), -* Thm ("separate_1_bdv", num_str separate_1_bdv), -* (*"?bdv / ?b = (1 / ?b) * ?bdv"*) -* Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*, -* (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) -* Thm ("real_add_divide_distrib", -* num_str real_add_divide_distrib) -* (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)*) -* ]), -* Calc ("HOL.divide" ,eval_cancel "#divide_") -* ], -* scr = EmptyScr -* }:rls); -.......................................................................*) - -val integration = - Seq {id="integration", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Rls {id="conditions_in_integration", - preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Erls, - srls = Erls, calc = [], - rules = [], - scr = EmptyScr}, - srls = Erls, calc = [], - rules = [ Rls_ integration_rules, - Rls_ add_new_c, - Rls_ simplify_Integral - ], - scr = EmptyScr}; -ruleset' := -overwritelthy thy (!ruleset', - [("integration_rules", prep_rls integration_rules), - ("add_new_c", prep_rls add_new_c), - ("simplify_Integral", prep_rls simplify_Integral), - ("integration", prep_rls integration), - ("separate_bdv2", separate_bdv2), - ("norm_Rational_noadd_fractions", norm_Rational_noadd_fractions), - ("norm_Rational_rls_noadd_fractions", - norm_Rational_rls_noadd_fractions) - ]); - -(** problems **) - -store_pbt - (prep_pbt Integrate.thy "pbl_fun_integ" [] e_pblID - (["integrate","function"], - [("#Given" ,["functionTerm f_", "integrateBy v_"]), - ("#Find" ,["antiDerivative F_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "Integrate (f_, v_)", - [["diff","integration"]])); - -(*here "named" is used differently from Differentiation"*) -store_pbt - (prep_pbt Integrate.thy "pbl_fun_integ_nam" [] e_pblID - (["named","integrate","function"], - [("#Given" ,["functionTerm f_", "integrateBy v_"]), - ("#Find" ,["antiDerivativeName F_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "Integrate (f_, v_)", - [["diff","integration","named"]])); - -(** methods **) - -store_met - (prep_met Integrate.thy "met_diffint" [] e_metID - (["diff","integration"], - [("#Given" ,["functionTerm f_", "integrateBy v_"]), - ("#Find" ,["antiDerivative F_"]) - ], - {rew_ord'="tless_true", rls'=Atools_erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"Script IntegrationScript (f_::real) (v_::real) = \ -\ (let t_ = Take (Integral f_ D v_) \ -\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) (t_::real))" -)); - -store_met - (prep_met Integrate.thy "met_diffint_named" [] e_metID - (["diff","integration","named"], - [("#Given" ,["functionTerm f_", "integrateBy v_"]), - ("#Find" ,["antiDerivativeName F_"]) - ], - {rew_ord'="tless_true", rls'=Atools_erls, calc = [], - srls = e_rls, - prls=e_rls, - crls = Atools_erls, nrls = e_rls}, -"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \ -\ (let t_ = Take (F_ v_ = Integral f_ D v_) \ -\ in ((Try (Rewrite_Set_Inst [(bdv,v_)] simplify_Integral False)) @@\ -\ (Rewrite_Set_Inst [(bdv,v_)] integration False)) t_)" -(* -"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \ -\ (let t_ = Take (F_ v_ = Integral f_ D v_) \ -\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) t_)" -*) - )); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Integrate.thy --- a/src/Tools/isac/IsacKnowledge/Integrate.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -(* integration over the reals - author: Walther Neuper - 050814, 08:51 - (c) due to copyright terms - -remove_thy"Integrate"; -use_thy"IsacKnowledge/Integrate"; -use_thy_only"IsacKnowledge/Integrate"; - -remove_thy"Typefix"; -use_thy"IsacKnowledge/Isac"; -*) - -Integrate = Diff + - -consts - - Integral :: "[real, real]=> real" ("Integral _ D _" 91) -(*new'_c :: "real => real" ("new'_c _" 66)*) - is'_f'_x :: "real => bool" ("_ is'_f'_x" 10) - - (*descriptions in the related problems*) - integrateBy :: real => una - antiDerivative :: real => una - antiDerivativeName :: (real => real) => una - - (*the CAS-command, eg. "Integrate (2*x^^^3, x)"*) - Integrate :: "[real * real] => real" - - (*Script-names*) - IntegrationScript :: "[real,real, real] => real" - ("((Script IntegrationScript (_ _ =))// (_))" 9) - NamedIntegrationScript :: "[real,real, real=>real, bool] => bool" - ("((Script NamedIntegrationScript (_ _ _=))// (_))" 9) - -rules -(*stated as axioms, todo: prove as theorems - 'bdv' is a constant handled on the meta-level - specifically as a 'bound variable' *) - - integral_const "Not (bdv occurs_in u) ==> Integral u D bdv = u * bdv" - integral_var "Integral bdv D bdv = bdv ^^^ 2 / 2" - - integral_add "Integral (u + v) D bdv = \ - \(Integral u D bdv) + (Integral v D bdv)" - integral_mult "[| Not (bdv occurs_in u); bdv occurs_in v |] ==> \ - \Integral (u * v) D bdv = u * (Integral v D bdv)" -(*WN080222: this goes into sub-terms, too ... - call_for_new_c "[| Not (matches (u + new_c v) a); Not (a is_f_x) |] ==> \ - \a = a + new_c a" -*) - integral_pow "Integral bdv ^^^ n D bdv = bdv ^^^ (n+1) / (n + 1)" - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Isac.ML --- a/src/Tools/isac/IsacKnowledge/Isac.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -(* collect all knowledge defined in theories so far - author: Walther Neuper 0003 - (c) isac-team - -use"IsacKnowledge/Isac.ML"; -use"Isac.ML"; - *) - - -theory' := overwritel (!theory', [("Isac.thy",Isac.thy)]); - - -(**.set up a list for getting guh + theID for a thm (defined in isabelle).**) - -(*.get all theorems used by isac and defined in isabelle.*) -local - val isacrlsthms = ((gen_distinct eq_thmI) o (map rep_thm_G') o flat o - (map (thms_of_rls o #2 o #2))) (!ruleset'); - val isacthms = (flat o (map (PureThy.all_thms_of o #2))) (!theory'); -in - val rlsthmsNOTisac = gen_diff eq_thmI (isacrlsthms, isacthms); -end; - -(*.set up the list using 'val first_isac_thy' (see ListG.ML).*) -isab_thm_thy := make_isab rlsthmsNOTisac - ((#ancestors o rep_theory) first_isac_thy); - - -(*.create the hierarchy of theory elements from IsacKnowledge - including thms from Isabelle used in rls; - elements store_*d in any *.ML are not overwritten.*) - -thehier := the_hier (!thehier) (collect_thydata ()); -writeln("----------------------------------\n\ - \*** insert: not found ... IS OK : \n\ - \comes from fill_parents \n\ - \----------------------------------\n"); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Isac.thy --- a/src/Tools/isac/IsacKnowledge/Isac.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -(* theory collecting all knowledge defined so far - WN.11.00 - *) - -Isac = PolyMinus + PolyEq + Vect + DiffApp + Biegelinie + AlgEin - + (*InsSort +*) Test + - -end - -(* dependencies alternative to those defined by R.Lang during his thesis: - - Poly Root - |\__________ | - | \ | - | Rational | - | | | - PolyEq RatEq RootEq - \ / \ / - \ / \ / - RatPolyEq RatRootEq etc. -*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/LinEq.ML --- a/src/Tools/isac/IsacKnowledge/LinEq.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,171 +0,0 @@ -(*. (c) by Richard Lang, 2003 .*) -(* collecting all knowledge for LinearEquations - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.11.04 -*) - -(* remove_thy"LinEq"; - use_thy"IsacKnowledge/Isac"; - - use_thy"IsacKnowledge/LinEq"; - - use"ROOT.ML"; - cd"knowledge"; -*) - -"******* LinEq.ML begin *******"; - -(*-------------------- theory -------------------------------------------------*) -theory' := overwritel (!theory', [("LinEq.thy",LinEq.thy)]); - -(*-------------- rules -------------------------------------------------------*) -val LinEq_prls = (*3.10.02:just the following order due to subterm evaluation*) - append_rls "LinEq_prls" e_rls - [Calc ("op =",eval_equal "#equal_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Tools.lhs" ,eval_lhs ""), - Calc ("Tools.rhs" ,eval_rhs ""), - Calc ("Poly.has'_degree'_in",eval_has_degree_in ""), - Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""), - Calc ("Atools.occurs'_in",eval_occurs_in ""), - Calc ("Atools.ident",eval_ident "#ident_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false), - Thm ("or_true",num_str or_true), - Thm ("or_false",num_str or_false) - ]; -(* ----- erls ----- *) -val LinEq_crls = - append_rls "LinEq_crls" poly_crls - [Thm ("real_assoc_1",num_str real_assoc_1) - (* - Don't use - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - *) - ]; - -(* ----- crls ----- *) -val LinEq_erls = - append_rls "LinEq_erls" Poly_erls - [Thm ("real_assoc_1",num_str real_assoc_1) - (* - Don't use - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - *) - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("LinEq_erls",LinEq_erls)(*FIXXXME:del with rls.rls'*) - ]); - -val LinPoly_simplify = prep_rls( - Rls {id = "LinPoly_simplify", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = LinEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [ - Thm ("real_assoc_1",num_str real_assoc_1), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_"), - (* Dont use - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - *) - Calc ("Atools.pow" ,eval_binop "#power_") - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("LinPoly_simplify",LinPoly_simplify)]); - -(*isolate the bound variable in an linear equation; 'bdv' is a meta-constant*) -val LinEq_simplify = prep_rls( -Rls {id = "LinEq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = LinEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("lin_isolate_div","")],*) - rules = [ - Thm("lin_isolate_add1",num_str lin_isolate_add1), - (* a+bx=0 -> bx=-a *) - Thm("lin_isolate_add2",num_str lin_isolate_add2), - (* a+ x=0 -> x=-a *) - Thm("lin_isolate_div",num_str lin_isolate_div) - (* bx=c -> x=c/b *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("LinEq_simplify",LinEq_simplify)]); - -(*----------------------------- problem types --------------------------------*) -(* -show_ptyps(); -(get_pbt ["linear","univariate","equation"]); -*) -(* ---------linear----------- *) -store_pbt - (prep_pbt LinEq.thy "pbl_equ_univ_lin" [] e_pblID - (["linear","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["False", (*WN0509 just detected: this pbl can never be used?!?*) - "Not( (lhs e_) is_polyrat_in v_)", - "Not( (rhs e_) is_polyrat_in v_)", - "((lhs e_) has_degree_in v_)=1", - "((rhs e_) has_degree_in v_)=1"]), - ("#Find" ,["solutions v_i_"]) - ], - LinEq_prls, SOME "solve (e_::bool, v_)", - [["LinEq","solve_lineq_equation"]])); - -(*-------------- methods-------------------------------------------------------*) -store_met - (prep_met LinEq.thy "met_eqlin" [] e_metID - (["LinEq"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=LinEq_crls, nrls=norm_Poly - (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); - -(* ansprechen mit ["LinEq","solve_univar_equation"] *) -store_met -(prep_met LinEq.thy "met_eq_lin" [] e_metID - (["LinEq","solve_lineq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["Not( (lhs e_) is_polyrat_in v_)", - "( (lhs e_) has_degree_in v_)=1"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=LinEq_erls, - srls=e_rls, - prls=LinEq_prls, - calc=[], - crls=LinEq_crls, nrls=norm_Poly(*, - asm_rls=[], - asm_thm=[("lin_isolate_div","")]*)}, - "Script Solve_lineq_equation (e_::bool) (v_::real) = \ - \(let e_ =((Try (Rewrite all_left False)) @@ \ - \ (Try (Repeat (Rewrite makex1_x False))) @@ \ - \ (Try (Rewrite_Set expand_binoms False)) @@ \ - \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ make_ratpoly_in False))) @@ \ - \ (Try (Repeat (Rewrite_Set LinPoly_simplify False)))) e_;\ - \ e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ LinEq_simplify True)) @@ \ - \ (Repeat(Try (Rewrite_Set LinPoly_simplify False)))) e_ \ - \ in ((Or_to_List e_)::bool list))" - )); -"******* LinEq.ML end *******"; -get_met ["LinEq","solve_lineq_equation"]; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/LinEq.thy --- a/src/Tools/isac/IsacKnowledge/LinEq.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -(*. (c) by Richard Lang, 2003 .*) -(* theory collecting all knowledge for LinearEquations - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.10.20 -*) - -(* - use"knowledge/LinEq.ML"; - use"LinEq.ML"; - - use"ROOT.ML"; - cd"knowledge"; - -*) - -LinEq = Poly + Equation + - -(*-------------------- consts------------------------------------------------*) -consts - Solve'_lineq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_lineq'_equation (_ _ =))// \ - \ (_))" 9) - -(*-------------------- rules -------------------------------------------------*) -rules -(*-- normalize --*) - (*WN0509 compare PolyEq.all_left "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"*) - all_left - "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)" - makex1_x - "a^^^1 = a" - real_assoc_1 - "a+(b+c) = a+b+c" - real_assoc_2 - "a*(b*c) = a*b*c" - -(*-- solve --*) - lin_isolate_add1 - "(a + b*bdv = 0) = (b*bdv = (-1)*a)" - lin_isolate_add2 - "(a + bdv = 0) = ( bdv = (-1)*a)" - lin_isolate_div - "[|Not(b=0)|] ==> (b*bdv = c) = (bdv = c / b)" -end - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/LogExp.ML --- a/src/Tools/isac/IsacKnowledge/LogExp.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -(* all outcommented in order to demonstrate authoring: - WN071203 -*) - -(** interface isabelle -- isac **) -theory' := overwritel (!theory', [("LogExp.thy",LogExp.thy)]); - -(*--------------------------------------------------*) - -(** problems **) -store_pbt - (prep_pbt LogExp.thy "pbl_test_equ_univ_log" [] e_pblID - (["logarithmic","univariate","equation"], - [("#Given",["equality e_","solveFor v_"]), - ("#Where",["matches ((?a log ?v_) = ?b) e_"]), - ("#Find" ,["solutions v_i_"]), - ("#With" ,["||(lhs (Subst (v_i_,v_) e_) - \ - \ (rhs (Subst (v_i_,v_) e_) || < eps)"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["Equation","solve_log"]])); - -(** methods **) -store_met - (prep_met LogExp.thy "met_equ_log" [] e_metID - (["Equation","solve_log"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches ((?a log ?v_) = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls, - calc=[],crls=PolyEq_crls, nrls=norm_Rational}, - "Script Solve_log (e_::bool) (v_::real) = \ - \(let e_ = ((Rewrite equality_power False) @@ \ - \ (Rewrite exp_invers_log False) @@ \ - \ (Rewrite_Set norm_Poly False)) e_ \ - \ in [e_])" - )); -(*--------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/LogExp.thy --- a/src/Tools/isac/IsacKnowledge/LogExp.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -(* all outcommented in order to demonstrate authoring: - WN071203 -remove_thy"LogExp"; -use_thy_only"IsacKnowledge/LogExp"; -use_thy_only"IsacKnowledge/Isac"; -*) -LogExp = PolyEq + - -consts - - ln :: "real => real" - exp :: "real => real" ("E'_ ^^^ _" 80) - -(*--------------------------------------------------*) - alog :: "[real, real] => real" ("_ log _" 90) - - (*Script-names*) - Solve'_log :: "[bool,real, bool list] \ - \=> bool list" - ("((Script Solve'_log (_ _=))//(_))" 9) - -rules - - equality_pow "0 < a ==> (l = r) = (a^^^l = a^^^r)" - (* this is what students ^^^^^^^... are told to do *) - equality_power "((a log b) = c) = (a^^^(a log b) = a^^^c)" - exp_invers_log "a^^^(a log b) = b" -(*---------------------------------------------------*) - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Poly.ML --- a/src/Tools/isac/IsacKnowledge/Poly.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1495 +0,0 @@ -(*.eval_funs, rulesets, problems and methods concerning polynamials - authors: Matthias Goldgruber 2003 - (c) due to copyright terms - - use"../IsacKnowledge/Poly.ML"; - use"IsacKnowledge/Poly.ML"; - use"Poly.ML"; - - remove_thy"Poly"; - use_thy"IsacKnowledge/Isac"; -****************************************************************.*) - -(*.**************************************************************** - remark on 'polynomials' - WN020919 - there are 5 kinds of expanded normalforms: -[1] 'complete polynomial' (Komplettes Polynom), univariate - a_0 + a_1.x^1 +...+ a_n.x^n not (a_n = 0) - not (a_n = 0), some a_i may be zero (DON'T disappear), - variables in monomials lexicographically ordered and complete, - x written as 1*x^1, ... -[2] 'polynomial' (Polynom), univariate and multivariate - a_0 + a_1.x +...+ a_n.x^n not (a_n = 0) - 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 - not (a_n = 0), some a_i may be zero (ie. monomials disappear), - exponents and coefficients equal 1 are not (WN060904.TODO in cancel_p_)shown, - and variables in monomials are lexicographically ordered - examples: [1]: "1 + (-10) * x ^^^ 1 + 25 * x ^^^ 2" - [1]: "11 + 0 * x ^^^ 1 + 1 * x ^^^ 2" - [2]: "x + (-50) * x ^^^ 3" - [2]: "(-1) * x * y ^^^ 2 + 7 * x ^^^ 3" - -[3] 'expanded_term' (Ausmultiplizierter Term): - pull out unary minus to binary minus, - as frequently exercised in schools; other conditions for [2] hold however - examples: "a ^^^ 2 - 2 * a * b + b ^^^ 2" - "4 * x ^^^ 2 - 9 * y ^^^ 2" -[4] 'polynomial_in' (Polynom in): - polynomial in 1 variable with arbitrary coefficients - examples: "2 * x + (-50) * x ^^^ 3" (poly in x) - "(u + v) + (2 * u ^^^ 2) * a + (-u) * a ^^^ 2 (poly in a) -[5] 'expanded_in' (Ausmultiplizierter Termin in): - analoguous to [3] with binary minus like [3] - examples: "2 * x - 50 * x ^^^ 3" (expanded in x) - "(u + v) + (2 * u ^^^ 2) * a - u * a ^^^ 2 (expanded in a) -*****************************************************************.*) - -"******** Poly.ML begin ******************************************"; -theory' := overwritel (!theory', [("Poly.thy",Poly.thy)]); - - -(* is_polyrat_in becomes true, if no bdv is in the denominator of a fraction*) -fun is_polyrat_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun finddivide (_ $ _ $ _ $ _) v = raise error("is_polyrat_in:") - (* at the moment there is no term like this, but ....*) - | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = not(coeff_in b v) - | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) orelse (finddivide t2 v) - | finddivide (_ $ t1) v = (finddivide t1 v) - | finddivide _ _ = false; - in - finddivide t v - end; - -fun eval_is_polyrat_in _ _ (p as (Const ("Poly.is'_polyrat'_in",_) $ t $ v)) _ = - if is_polyrat_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_polyrat_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - - -local - (*.a 'c is coefficient of v' if v does NOT occur in c.*) - fun coeff_in c v = not (member op = (vars c) v); - (* - val v = (term_of o the o (parse thy)) "x"; - val t = (term_of o the o (parse thy)) "1"; - coeff_in t v; - (*val it = true : bool*) - val t = (term_of o the o (parse thy)) "a*b+c"; - coeff_in t v; - (*val it = true : bool*) - val t = (term_of o the o (parse thy)) "a*x+c"; - coeff_in t v; - (*val it = false : bool*) - *) - (*. a 'monomial t in variable v' is a term t with - either (1) v NOT existent in t, or (2) v contained in t, - if (1) then degree 0 - if (2) then v is a factor on the very right, ev. with exponent.*) - fun factor_right_deg (*case 2*) - (t as Const ("op *",_) $ t1 $ - (Const ("Atools.pow",_) $ vv $ Free (d,_))) v = - if ((vv = v) andalso (coeff_in t1 v)) then SOME (int_of_str' d) else NONE - | factor_right_deg - (t as Const ("Atools.pow",_) $ vv $ Free (d,_)) v = - if (vv = v) then SOME (int_of_str' d) else NONE - | factor_right_deg (t as Const ("op *",_) $ t1 $ vv) v = - if ((vv = v) andalso (coeff_in t1 v))then SOME 1 else NONE - | factor_right_deg vv v = - if (vv = v) then SOME 1 else NONE; - fun mono_deg_in m v = - if coeff_in m v then (*case 1*) SOME 0 - else factor_right_deg m v; - (* - val v = (term_of o the o (parse thy)) "x"; - val t = (term_of o the o (parse thy)) "(a*b+c)*x^^^7"; - mono_deg_in t v; - (*val it = SOME 7*) - val t = (term_of o the o (parse thy)) "x^^^7"; - mono_deg_in t v; - (*val it = SOME 7*) - val t = (term_of o the o (parse thy)) "(a*b+c)*x"; - mono_deg_in t v; - (*val it = SOME 1*) - val t = (term_of o the o (parse thy)) "(a*b+x)*x"; - mono_deg_in t v; - (*val it = NONE*) - val t = (term_of o the o (parse thy)) "x"; - mono_deg_in t v; - (*val it = SOME 1*) - val t = (term_of o the o (parse thy)) "(a*b+c)"; - mono_deg_in t v; - (*val it = SOME 0*) - val t = (term_of o the o (parse thy)) "ab - (a*b)*x"; - mono_deg_in t v; - (*val it = NONE*) - *) - fun expand_deg_in t v = - let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) = - (case mono_deg_in t2 v of (* $ is left associative*) - SOME d' => edi d' d' t1 - | NONE => NONE) - | edi ~1 ~1 (Const ("op -",_) $ t1 $ t2) = - (case mono_deg_in t2 v of - SOME d' => edi d' d' t1 - | NONE => NONE) - | edi d dmax (Const ("op -",_) $ t1 $ t2) = - (case mono_deg_in t2 v of - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE - | NONE => NONE) - | edi d dmax (Const ("op +",_) $ t1 $ t2) = - (case mono_deg_in t2 v of - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE - | NONE => NONE) - | edi ~1 ~1 t = - (case mono_deg_in t v of - d as SOME _ => d - | NONE => NONE) - | edi d dmax t = (*basecase last*) - (case mono_deg_in t v of - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE - | NONE => NONE) - in edi ~1 ~1 t end; - (* - val v = (term_of o the o (parse thy)) "x"; - val t = (term_of o the o (parse thy)) "a+b"; - expand_deg_in t v; - (*val it = SOME 0*) - val t = (term_of o the o (parse thy)) "(a+b)*x"; - expand_deg_in t v; - (*SOME 1*) - val t = (term_of o the o (parse thy)) "a*b - (a+b)*x"; - expand_deg_in t v; - (*SOME 1*) - val t = (term_of o the o (parse thy)) "a*b + (a-b)*x"; - expand_deg_in t v; - (*SOME 1*) - val t = (term_of o the o (parse thy)) "a*b + (a+b)*x + x^^^2"; - expand_deg_in t v; - *) - fun poly_deg_in t v = - let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) = - (case mono_deg_in t2 v of (* $ is left associative*) - SOME d' => edi d' d' t1 - | NONE => NONE) - | edi d dmax (Const ("op +",_) $ t1 $ t2) = - (case mono_deg_in t2 v of - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE - | NONE => NONE) - | edi ~1 ~1 t = - (case mono_deg_in t v of - d as SOME _ => d - | NONE => NONE) - | edi d dmax t = (*basecase last*) - (case mono_deg_in t v of - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE - | NONE => NONE) - in edi ~1 ~1 t end; -in - -fun is_expanded_in t v = - case expand_deg_in t v of SOME _ => true | NONE => false; -fun is_poly_in t v = - case poly_deg_in t v of SOME _ => true | NONE => false; -fun has_degree_in t v = - case expand_deg_in t v of SOME d => d | NONE => ~1; -end; -(* - val v = (term_of o the o (parse thy)) "x"; - val t = (term_of o the o (parse thy)) "a*b - (a+b)*x + x^^^2"; - has_degree_in t v; - (*val it = 2*) - val t = (term_of o the o (parse thy)) "-8 - 2*x + x^^^2"; - has_degree_in t v; - (*val it = 2*) - val t = (term_of o the o (parse thy)) "6 + 13*x + 6*x^^^2"; - has_degree_in t v; - (*val it = 2*) -*) - -(*("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in ""))*) -fun eval_is_expanded_in _ _ - (p as (Const ("Poly.is'_expanded'_in",_) $ t $ v)) _ = - if is_expanded_in t v - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_expanded_in _ _ _ _ = NONE; -(* - val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) is_expanded_in x"; - val SOME (id, t') = eval_is_expanded_in 0 0 t 0; - (*val id = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*) - term2str t'; - (*val it = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*) -*) -(*("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in ""))*) -fun eval_is_poly_in _ _ - (p as (Const ("Poly.is'_poly'_in",_) $ t $ v)) _ = - if is_poly_in t v - then SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_poly_in _ _ _ _ = NONE; -(* - val t = (term_of o the o (parse thy)) "(8 + 2*x + x^^^2) is_poly_in x"; - val SOME (id, t') = eval_is_poly_in 0 0 t 0; - (*val id = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*) - term2str t'; - (*val it = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*) -*) - -(*("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in ""))*) -fun eval_has_degree_in _ _ - (p as (Const ("Poly.has'_degree'_in",_) $ t $ v)) _ = - let val d = has_degree_in t v - val d' = term_of_num HOLogic.realT d - in SOME ((term2str p) ^ " = " ^ (string_of_int d), - Trueprop $ (mk_equality (p, d'))) - end - | eval_has_degree_in _ _ _ _ = NONE; -(* -> val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) has_degree_in x"; -> val SOME (id, t') = eval_has_degree_in 0 0 t 0; -val id = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string -> term2str t'; -val it = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string -*) - -(*..*) -val calculate_Poly = - append_rls "calculate_PolyFIXXXME.not.impl." e_rls - []; - -(*.for evaluation of conditions in rewrite rules.*) -val Poly_erls = - append_rls "Poly_erls" Atools_erls - [ Calc ("op =",eval_equal "#equal_"), - Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("Atools.pow" ,eval_binop "#power_") - ]; - -val poly_crls = - append_rls "poly_crls" Atools_crls - [ Calc ("op =",eval_equal "#equal_"), - Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("Atools.pow" ,eval_binop "#power_") - ]; - - -local (*. for make_polynomial .*) - -open Term; (* for type order = EQUAL | LESS | GREATER *) - -fun pr_ord EQUAL = "EQUAL" - | pr_ord LESS = "LESS" - | pr_ord GREATER = "GREATER"; - -fun dest_hd' (Const (a, T)) = (* ~ term.ML *) - (case a of - "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest string*) - | _ => (((a, 0), T), 0)) - | dest_hd' (Free (a, T)) = (((a, 0), T), 1) - | dest_hd' (Var v) = (v, 2) - | dest_hd' (Bound i) = ((("", i), dummyT), 3) - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); - -fun get_order_pow (t $ (Free(order,_))) = (* RL FIXXXME:geht zufaellig?WN*) - (case int_of_str (order) of - SOME d => d - | NONE => 0) - | get_order_pow _ = 0; - -fun size_of_term' (Const(str,_) $ t) = - if "Atools.pow"= str then 1000 + size_of_term' t else 1+size_of_term' t(*WN*) - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body - | size_of_term' (f$t) = size_of_term' f + size_of_term' t - | size_of_term' _ = 1; - -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) - | term_ord' pr thy (t, u) = - (if pr then - let - val (f, ts) = strip_comb t and (g, us) = strip_comb u; - val _=writeln("t= f@ts= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy))ts))^"]\""); - val _=writeln("u= g@us= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy))us))^"]\""); - val _=writeln("size_of_term(t,u)= ("^ - (string_of_int(size_of_term' t))^", "^ - (string_of_int(size_of_term' u))^")"); - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); - val _=writeln("terms_ord(ts,us) = "^ - ((pr_ord o terms_ord str false)(ts,us))); - val _=writeln("-------"); - in () end - else (); - case int_ord (size_of_term' t, size_of_term' u) of - EQUAL => - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) - | ord => ord) - end - | ord => ord) -and hd_ord (f, g) = (* ~ term.ML *) - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) -and terms_ord str pr (ts, us) = - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); -in - -fun ord_make_polynomial (pr:bool) thy (_:subst) tu = - (term_ord' pr thy(***) tu = LESS ); - -end;(*local*) - - -rew_ord' := overwritel (!rew_ord', -[("termlessI", termlessI), - ("ord_make_polynomial", ord_make_polynomial false thy) - ]); - - -val expand = - Rls{id = "expand", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2) - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - ], scr = EmptyScr}:rls; - -(*----------------- Begin: rulesets for make_polynomial_ ----------------- - 'rlsIDs' redefined by MG as 'rlsIDs_' - ^^^*) - -val discard_minus_ = - Rls{id = "discard_minus_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_diff_minus",num_str real_diff_minus), - (*"a - b = a + -1 * b"*) - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) - (*- ?z = "-1 * ?z"*) - ], scr = EmptyScr}:rls; -val expand_poly_ = - Rls{id = "expand_poly_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_plus_binom_pow4",num_str real_plus_binom_pow4), - (*"(a + b)^^^4 = ... "*) - Thm ("real_plus_binom_pow5",num_str real_plus_binom_pow5), - (*"(a + b)^^^5 = ... "*) - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), - (*"(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *) - - (*WN071229 changed/removed for Schaerding -----vvv*) - (*Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),*) - (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) - Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2), - (*"(a + b)^^^2 = (a + b) * (a + b)"*) - (*Thm ("real_plus_minus_binom1_p_p", - num_str real_plus_minus_binom1_p_p),*) - (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*) - (*Thm ("real_plus_minus_binom2_p_p", - num_str real_plus_minus_binom2_p_p),*) - (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*) - (*WN071229 changed/removed for Schaerding -----^^^*) - - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - - Thm ("realpow_multI", num_str realpow_multI), - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) - Thm ("realpow_pow",num_str realpow_pow) - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) - ], scr = EmptyScr}:rls; - -(*.the expression contains + - * ^ only ? - this is weaker than 'is_polynomial' !.*) -fun is_polyexp (Free _) = true - | is_polyexp (Const ("op +",_) $ Free _ $ Free _) = true - | is_polyexp (Const ("op -",_) $ Free _ $ Free _) = true - | is_polyexp (Const ("op *",_) $ Free _ $ Free _) = true - | is_polyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true - | is_polyexp (Const ("op +",_) $ t1 $ t2) = - ((is_polyexp t1) andalso (is_polyexp t2)) - | is_polyexp (Const ("op -",_) $ t1 $ t2) = - ((is_polyexp t1) andalso (is_polyexp t2)) - | is_polyexp (Const ("op *",_) $ t1 $ t2) = - ((is_polyexp t1) andalso (is_polyexp t2)) - | is_polyexp (Const ("Atools.pow",_) $ t1 $ t2) = - ((is_polyexp t1) andalso (is_polyexp t2)) - | is_polyexp _ = false; - -(*("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp ""))*) -fun eval_is_polyexp (thmid:string) _ - (t as (Const("Poly.is'_polyexp", _) $ arg)) thy = - if is_polyexp arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.true_const))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.false_const))) - | eval_is_polyexp _ _ _ _ = NONE; - -val expand_poly_rat_ = - Rls{id = "expand_poly_rat_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = append_rls "e_rls-is_polyexp" e_rls - [Calc ("Poly.is'_polyexp", eval_is_polyexp "") - ], - srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_plus_binom_pow4_poly",num_str real_plus_binom_pow4_poly), - (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^4 = ... "*) - Thm ("real_plus_binom_pow5_poly",num_str real_plus_binom_pow5_poly), - (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^5 = ... "*) - Thm ("real_plus_binom_pow2_poly",num_str real_plus_binom_pow2_poly), - (*"[| a is_polyexp; b is_polyexp |] ==> - (a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) - Thm ("real_plus_binom_pow3_poly",num_str real_plus_binom_pow3_poly), - (*"[| a is_polyexp; b is_polyexp |] ==> - (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *) - Thm ("real_plus_minus_binom1_p_p",num_str real_plus_minus_binom1_p_p), - (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*) - Thm ("real_plus_minus_binom2_p_p",num_str real_plus_minus_binom2_p_p), - (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*) - - Thm ("real_add_mult_distrib_poly" ,num_str real_add_mult_distrib_poly), - (*"w is_polyexp ==> (z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2_poly",num_str real_add_mult_distrib2_poly), - (*"w is_polyexp ==> w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - - Thm ("realpow_multI_poly", num_str realpow_multI_poly), - (*"[| r is_polyexp; s is_polyexp |] ==> - (r * s) ^^^ n = r ^^^ n * s ^^^ n"*) - Thm ("realpow_pow",num_str realpow_pow) - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) - ], scr = EmptyScr}:rls; - -val simplify_power_ = - Rls{id = "simplify_power_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls, srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [(*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen - a*(a*a) --> a*a^^^2 und nicht a*(a*a) --> a^^^2*a *) - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r * r = r ^^^ 2"*) - Thm ("realpow_twoI_assoc_l",num_str realpow_twoI_assoc_l), - (*"r * (r * s) = r ^^^ 2 * s"*) - - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("realpow_plus_1_assoc_l", num_str realpow_plus_1_assoc_l), - (*"r * (r ^^^ m * s) = r ^^^ (1 + m) * s"*) - (*MG 9.7.03: neues Thm wegen a*(a*(a*b)) --> a^^^2*(a*b) *) - Thm ("realpow_plus_1_assoc_l2", num_str realpow_plus_1_assoc_l2), - (*"r ^^^ m * (r * s) = r ^^^ (1 + m) * s"*) - - Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)), - (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) - Thm ("realpow_addI_assoc_l", num_str realpow_addI_assoc_l), - (*"r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"*) - - (* ist in expand_poly - wird hier aber auch gebraucht, wegen: - "r * r = r ^^^ 2" wenn r=a^^^b*) - Thm ("realpow_pow",num_str realpow_pow) - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) - ], scr = EmptyScr}:rls; - -val calc_add_mult_pow_ = - Rls{id = "calc_add_mult_pow_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls(*erls3.4.03*),srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], scr = EmptyScr}:rls; - -val reduce_012_mult_ = - Rls{id = "reduce_012_mult_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [(* MG: folgende Thm müssen hier stehen bleiben: *) - Thm ("real_mult_1_right",num_str real_mult_1_right), - (*"z * 1 = z"*) (*wegen "a * b * b^^^(-1) + a"*) - Thm ("realpow_zeroI",num_str realpow_zeroI), - (*"r ^^^ 0 = 1"*) (*wegen "a*a^^^(-1)*c + b + c"*) - Thm ("realpow_oneI",num_str realpow_oneI), - (*"r ^^^ 1 = r"*) - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI) - (*"1 ^^^ n = 1"*) - ], scr = EmptyScr}:rls; - -val collect_numerals_ = - Rls{id = "collect_numerals_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")) - ], - rules = [Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r), - (*"[| l is_const; m is_const |] ==> \ - \(k + m * n) + l * n = k + (l + m)*n"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r), - (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*) - - Calc ("op +", eval_binop "#add_"), - - (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen - (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *) - Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r), - (*"(k + z1) + z1 = k + 2 * z1"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)) - (*"z1 + z1 = 2 * z1"*) - - ], scr = EmptyScr}:rls; - -val reduce_012_ = - Rls{id = "reduce_012_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_mult_0_right",num_str real_mult_0_right), - (*"z * 0 = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - Thm ("real_add_zero_right",num_str real_add_zero_right), - (*"z + 0 = z"*) (*wegen a+b-b --> a+(1-1)*b --> a+0 --> a*) - - (*Thm ("realpow_oneI",num_str realpow_oneI)*) - (*"?r ^^^ 1 = ?r"*) - Thm ("real_0_divide",num_str real_0_divide)(*WN060914*) - (*"0 / ?x = 0"*) - ], scr = EmptyScr}:rls; - -(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*) -val discard_parentheses_ = - append_rls "discard_parentheses_" e_rls - [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)) - (*"?z1.1 * (?z2.1 * ?z3.1) = ?z1.1 * ?z2.1 * ?z3.1"*) - (*Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))*) - (*"?z1.1 + (?z2.1 + ?z3.1) = ?z1.1 + ?z2.1 + ?z3.1"*) - ]; - -(*----------------- End: rulesets for make_polynomial_ -----------------*) - -(*MG.0401 ev. for use in rls with ordered rewriting ? -val collect_numerals_left = - Rls{id = "collect_numerals", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls(*erls3.4.03*),srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> - l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> n + (m * n + k) = (1 + m) * n + k"*) - - Calc ("op +", eval_binop "#add_"), - - (*MG am 2.5.03: 2 Theoreme aus reduce_012 hierher verschoben*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc) - (*"z1 + (z1 + k) = 2 * z1 + k"*) - ], scr = EmptyScr}:rls;*) - -val expand_poly = - Rls{id = "expand_poly", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - (*Thm ("real_add_mult_distrib1",num_str real_add_mult_distrib1), - ....... 18.3.03 undefined???*) - - Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2), - (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) - Thm ("real_minus_binom_pow2_p",num_str real_minus_binom_pow2_p), - (*"(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"*) - Thm ("real_plus_minus_binom1_p", - num_str real_plus_minus_binom1_p), - (*"(a + b)*(a - b) = a^^^2 + -1*b^^^2"*) - Thm ("real_plus_minus_binom2_p", - num_str real_plus_minus_binom2_p), - (*"(a - b)*(a + b) = a^^^2 + -1*b^^^2"*) - - Thm ("real_minus_minus",num_str real_minus_minus), - (*"- (- ?z) = ?z"*) - Thm ("real_diff_minus",num_str real_diff_minus), - (*"a - b = a + -1 * b"*) - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) - (*- ?z = "-1 * ?z"*) - - (*Thm ("",num_str ), - Thm ("",num_str ), - Thm ("",num_str ),*) - (*Thm ("real_minus_add_distrib", - num_str real_minus_add_distrib),*) - (*"- (?x + ?y) = - ?x + - ?y"*) - (*Thm ("real_diff_plus",num_str real_diff_plus)*) - (*"a - b = a + -b"*) - ], scr = EmptyScr}:rls; -val simplify_power = - Rls{id = "simplify_power", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls, srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("realpow_multI", num_str realpow_multI), - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("realpow_pow",num_str realpow_pow), - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) - Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)), - (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) - Thm ("realpow_oneI",num_str realpow_oneI), - (*"r ^^^ 1 = r"*) - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI) - (*"1 ^^^ n = 1"*) - ], scr = EmptyScr}:rls; -(*MG.0401: termorders for multivariate polys dropped due to principal problems: - (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*) -val order_add_mult = - Rls{id = "order_add_mult", preconds = [], - rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_mult_commute",num_str real_mult_commute), - (* z * w = w * z *) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) - Thm ("real_mult_assoc",num_str real_mult_assoc), - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) - Thm ("real_add_commute",num_str real_add_commute), - (*z + w = w + z*) - Thm ("real_add_left_commute",num_str real_add_left_commute), - (*x + (y + z) = y + (x + z)*) - Thm ("real_add_assoc",num_str real_add_assoc) - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) - ], scr = EmptyScr}:rls; -(*MG.0401: termorders for multivariate polys dropped due to principal problems: - (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*) -val order_mult = - Rls{id = "order_mult", preconds = [], - rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_mult_commute",num_str real_mult_commute), - (* z * w = w * z *) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) - Thm ("real_mult_assoc",num_str real_mult_assoc) - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) - ], scr = EmptyScr}:rls; -val collect_numerals = - Rls{id = "collect_numerals", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls(*erls3.4.03*),srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> - l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], scr = EmptyScr}:rls; -val reduce_012 = - Rls{id = "reduce_012", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - (*Thm ("real_mult_minus1",num_str real_mult_minus1),14.3.03*) - (*"-1 * z = - z"*) - Thm ("sym_real_mult_minus_eq1", - num_str (real_mult_minus_eq1 RS sym)), - (*- (?x * ?y) = "- ?x * ?y"*) - (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel), - (*"- ?x * - ?y = ?x * ?y"*)---*) - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - Thm ("real_add_minus",num_str real_add_minus), - (*"?z + - ?z = 0"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc) - (*"z1 + (z1 + k) = 2 * z1 + k"*) - ], scr = EmptyScr}:rls; -(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*) -val discard_parentheses = - append_rls "discard_parentheses" e_rls - [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)), - Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))]; - -val scr_make_polynomial = -"Script Expand_binoms t_ =\ -\(Repeat \ -\((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - -\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \ -\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \ -\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \ -\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \ -\ (Try (Repeat (Rewrite real_add_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_)))) \ -\ t_)"; - -(*version used by MG.02/03, overwritten by version AG in 04 below -val make_polynomial = prep_rls( - Seq{id = "make_polynomial", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [],(*asm_thm = [],*) - rules = [Rls_ expand_poly, - Rls_ order_add_mult, - Rls_ simplify_power, (*realpow_eq_oneI, eg. x^1 --> x *) - Rls_ collect_numerals, (*eg. x^(2+ -1) --> x^1 *) - Rls_ reduce_012, - Thm ("realpow_oneI",num_str realpow_oneI),(*in --^*) - Rls_ discard_parentheses - ], - scr = EmptyScr - }:rls); *) - -val scr_expand_binoms = -"Script Expand_binoms t_ =\ -\(Repeat \ -\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \ -\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \ -\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_))) @@ \ - -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_)))) \ -\ t_)"; - -val expand_binoms = - Rls{id = "expand_binoms", preconds = [], rew_ord = ("termlessI",termlessI), - erls = Atools_erls, srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), - (*"(a + b)*(a + b) = ...*) - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) - Thm ("real_minus_binom_times",num_str real_minus_binom_times), - (*"(a - b)*(a - b) = ...*) - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) - (*RL 020915*) - Thm ("real_pp_binom_times",num_str real_pp_binom_times), - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) - Thm ("real_pm_binom_times",num_str real_pm_binom_times), - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) - Thm ("real_mp_binom_times",num_str real_mp_binom_times), - (*(a - b)*(c + d) = a*c + a*d - b*c - b*d*) - Thm ("real_mm_binom_times",num_str real_mm_binom_times), - (*(a - b)*(c - d) = a*c - a*d - b*c + b*d*) - Thm ("realpow_multI",num_str realpow_multI), - (*(a*b)^^^n = a^^^n * b^^^n*) - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), - (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *) - Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3), - (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *) - - - (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) - *) - - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_"), - (* - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) - Thm ("real_mult_assoc",num_str real_mult_assoc), (**) - Thm ("real_add_commute",num_str real_add_commute), (**) - Thm ("real_add_left_commute",num_str real_add_left_commute), (**) - Thm ("real_add_assoc",num_str real_add_assoc), (**) - *) - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*)*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], - scr = Script ((term_of o the o (parse thy)) scr_expand_binoms) - }:rls; - - -"******* Poly.ML end ******* ...RL"; - - -(**. MG.03: make_polynomial_ ... uses SML-fun for ordering .**) - -(*FIXME.0401: make SML-order local to make_polynomial(_) *) -(*FIXME.0401: replace 'make_polynomial'(old) by 'make_polynomial_'(MG) *) -(* Polynom --> List von Monomen *) -fun poly2list (Const ("op +",_) $ t1 $ t2) = - (poly2list t1) @ (poly2list t2) - | poly2list t = [t]; - -(* Monom --> Liste von Variablen *) -fun monom2list (Const ("op *",_) $ t1 $ t2) = - (monom2list t1) @ (monom2list t2) - | monom2list t = [t]; - -(* liefert Variablenname (String) einer Variablen und Basis bei Potenz *) -fun get_basStr (Const ("Atools.pow",_) $ Free (str, _) $ _) = str - | get_basStr (Free (str, _)) = str - | get_basStr t = "|||"; (* gross gewichtet; für Brüch ect. *) -(*| get_basStr t = - raise error("get_basStr: called with t= "^(term2str t));*) - -(* liefert Hochzahl (String) einer Variablen bzw Gewichtstring (zum Sortieren) *) -fun get_potStr (Const ("Atools.pow",_) $ Free _ $ Free (str, _)) = str - | get_potStr (Const ("Atools.pow",_) $ Free _ $ _ ) = "|||" (* gross gewichtet *) - | get_potStr (Free (str, _)) = "---" (* keine Hochzahl --> kleinst gewichtet *) - | get_potStr t = "||||||"; (* gross gewichtet; für Brüch ect. *) -(*| get_potStr t = - raise error("get_potStr: called with t= "^(term2str t));*) - -(* Umgekehrte string_ord *) -val string_ord_rev = rev_order o string_ord; - - (* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen) - innerhalb eines Monomes: - - zuerst lexikographisch nach Variablenname - - wenn gleich: nach steigender Potenz *) -fun var_ord (a,b: term) = prod_ord string_ord string_ord - ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b)); - -(* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen); - verwendet zum Sortieren von Monomen mittels Gesamtgradordnung: - - zuerst lexikographisch nach Variablenname - - wenn gleich: nach sinkender Potenz*) -fun var_ord_revPow (a,b: term) = prod_ord string_ord string_ord_rev - ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b)); - - -(* Ordnet ein Liste von Variablen (und Potenzen) lexikographisch *) -val sort_varList = sort var_ord; - -(* Entfernet aeussersten Operator (Wurzel) aus einem Term und schreibt - Argumente in eine Liste *) -fun args u : term list = - let fun stripc (f$t, ts) = stripc (f, t::ts) - | stripc (t as Free _, ts) = (t::ts) - | stripc (_, ts) = ts - in stripc (u, []) end; - -(* liefert True, falls der Term (Liste von Termen) nur Zahlen - (keine Variablen) enthaelt *) -fun filter_num [] = true - | filter_num [Free x] = if (is_num (Free x)) then true - else false - | filter_num ((Free _)::_) = false - | filter_num ts = - (filter_num o (filter_out is_num) o flat o (map args)) ts; - -(* liefert True, falls der Term nur Zahlen (keine Variablen) enthaelt - dh. er ist ein numerischer Wert und entspricht einem Koeffizienten *) -fun is_nums t = filter_num [t]; - -(* Berechnet den Gesamtgrad eines Monoms *) -local - fun counter (n, []) = n - | counter (n, x :: xs) = - if (is_nums x) then - counter (n, xs) - else - (case x of - (Const ("Atools.pow", _) $ Free (str_b, _) $ Free (str_h, T)) => - if (is_nums (Free (str_h, T))) then - counter (n + (the (int_of_str str_h)), xs) - else counter (n + 1000, xs) (*FIXME.MG?!*) - | (Const ("Atools.pow", _) $ Free (str_b, _) $ _ ) => - counter (n + 1000, xs) (*FIXME.MG?!*) - | (Free (str, _)) => counter (n + 1, xs) - (*| _ => raise error("monom_degree: called with factor: "^(term2str x)))*) - | _ => counter (n + 10000, xs)) (*FIXME.MG?! ... Brüche ect.*) -in - fun monom_degree l = counter (0, l) -end; - -(* wie Ordnung dict_ord (lexicographische Ordnung zweier Listen, mit Vergleich - der Listen-Elemente mit elem_ord) - Elemente die Bedingung cond erfuellen, - werden jedoch dabei ignoriert (uebersprungen) *) -fun dict_cond_ord _ _ ([], []) = EQUAL - | dict_cond_ord _ _ ([], _ :: _) = LESS - | dict_cond_ord _ _ (_ :: _, []) = GREATER - | dict_cond_ord elem_ord cond (x :: xs, y :: ys) = - (case (cond x, cond y) of - (false, false) => (case elem_ord (x, y) of - EQUAL => dict_cond_ord elem_ord cond (xs, ys) - | ord => ord) - | (false, true) => dict_cond_ord elem_ord cond (x :: xs, ys) - | (true, false) => dict_cond_ord elem_ord cond (xs, y :: ys) - | (true, true) => dict_cond_ord elem_ord cond (xs, ys) ); - -(* Gesamtgradordnung zum Vergleich von Monomen (Liste von Variablen/Potenzen): - zuerst nach Gesamtgrad, bei gleichem Gesamtgrad lexikographisch ordnen - - dabei werden Koeffizienten ignoriert (2*3*a^^^2*4*b gilt wie a^^^2*b) *) -fun degree_ord (xs, ys) = - prod_ord int_ord (dict_cond_ord var_ord_revPow is_nums) - ((monom_degree xs, xs), (monom_degree ys, ys)); - -fun hd_str str = substring (str, 0, 1); -fun tl_str str = substring (str, 1, (size str) - 1); - -(* liefert nummerischen Koeffizienten eines Monoms oder NONE *) -fun get_koeff_of_mon [] = raise error("get_koeff_of_mon: called with l = []") - | get_koeff_of_mon (l as x::xs) = if is_nums x then SOME x - else NONE; - -(* wandelt Koeffizient in (zum sortieren geeigneten) String um *) -fun koeff2ordStr (SOME x) = (case x of - (Free (str, T)) => - if (hd_str str) = "-" then (tl_str str)^"0" (* 3 < -3 *) - else str - | _ => "aaa") (* "num.Ausdruck" --> gross *) - | koeff2ordStr NONE = "---"; (* "kein Koeff" --> kleinste *) - -(* Order zum Vergleich von Koeffizienten (strings): - "kein Koeff" < "0" < "1" < "-1" < "2" < "-2" < ... < "num.Ausdruck" *) -fun compare_koeff_ord (xs, ys) = - string_ord ((koeff2ordStr o get_koeff_of_mon) xs, - (koeff2ordStr o get_koeff_of_mon) ys); - -(* Gesamtgradordnung degree_ord + Ordnen nach Koeffizienten falls EQUAL *) -fun koeff_degree_ord (xs, ys) = - prod_ord degree_ord compare_koeff_ord ((xs, xs), (ys, ys)); - -(* Ordnet ein Liste von Monomen (Monom = Liste von Variablen) mittels - Gesamtgradordnung *) -val sort_monList = sort koeff_degree_ord; - -(* Alternativ zu degree_ord koennte auch die viel einfachere und - kuerzere Ordnung simple_ord verwendet werden - ist aber nicht - fuer unsere Zwecke geeignet! - -fun simple_ord (al,bl: term list) = dict_ord string_ord - (map get_basStr al, map get_basStr bl); - -val sort_monList = sort simple_ord; *) - -(* aus 2 Variablen wird eine Summe bzw ein Produkt erzeugt - (mit gewuenschtem Typen T) *) -fun plus T = Const ("op +", [T,T] ---> T); -fun mult T = Const ("op *", [T,T] ---> T); -fun binop op_ t1 t2 = op_ $ t1 $ t2; -fun create_prod T (a,b) = binop (mult T) a b; -fun create_sum T (a,b) = binop (plus T) a b; - -(* löscht letztes Element einer Liste *) -fun drop_last l = take ((length l)-1,l); - -(* Liste von Variablen --> Monom *) -fun create_monom T vl = foldr (create_prod T) (drop_last vl, last_elem vl); -(* Bemerkung: - foldr bewirkt rechtslastige Klammerung des Monoms - ist notwendig, damit zwei - gleiche Monome zusammengefasst werden können (collect_numerals)! - zB: 2*(x*(y*z)) + 3*(x*(y*z)) --> (2+3)*(x*(y*z))*) - -(* Liste von Monomen --> Polynom *) -fun create_polynom T ml = foldl (create_sum T) (hd ml, tl ml); -(* Bemerkung: - foldl bewirkt linkslastige Klammerung des Polynoms (der Summanten) - - bessere Darstellung, da keine Klammern sichtbar! - (und discard_parentheses in make_polynomial hat weniger zu tun) *) - -(* sorts the variables (faktors) of an expanded polynomial lexicographical *) -fun sort_variables t = - let - val ll = map monom2list (poly2list t); - val lls = map sort_varList ll; - val T = type_of t; - val ls = map (create_monom T) lls; - in create_polynom T ls end; - -(* sorts the monoms of an expanded and variable-sorted polynomial - by total_degree *) -fun sort_monoms t = - let - val ll = map monom2list (poly2list t); - val lls = sort_monList ll; - val T = type_of t; - val ls = map (create_monom T) lls; - in create_polynom T ls end; - -(* auch Klammerung muss übereinstimmen; - sort_variables klammert Produkte rechtslastig*) -fun is_multUnordered t = ((is_polyexp t) andalso not (t = sort_variables t)); - -fun eval_is_multUnordered (thmid:string) _ - (t as (Const("Poly.is'_multUnordered", _) $ arg)) thy = - if is_multUnordered arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.true_const))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.false_const))) - | eval_is_multUnordered _ _ _ _ = NONE; - - -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; -fun init_state (_:term) = e_rrlsstate; -fun locate_rule (_:rule list list) (_:term) (_:rule) = - ([]:(rule * (term * term list)) list); -fun next_rule (_:rule list list) (_:term) = (NONE:rule option); -fun normal_form t = SOME (sort_variables t,[]:term list); - -val order_mult_ = - Rrls {id = "order_mult_", - prepat = - [([(term_of o the o (parse thy)) "p is_multUnordered"], - (term_of o the o (parse thy)) "?p" )], - rew_ord = ("dummy_ord", dummy_ord), - erls = append_rls "e_rls-is_multUnordered" e_rls(*MG: poly_erls*) - [Calc ("Poly.is'_multUnordered", eval_is_multUnordered "") - ], - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - (*asm_thm=[],*) - scr=Rfuns {init_state = init_state, - normal_form = normal_form, - locate_rule = locate_rule, - next_rule = next_rule, - attach_form = attach_form}}; - -val order_mult_rls_ = - Rls{id = "order_mult_rls_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Rls_ order_mult_ - ], scr = EmptyScr}:rls; - -fun is_addUnordered t = ((is_polyexp t) andalso not (t = sort_monoms t)); - -(*WN.18.6.03 *) -(*("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))*) -fun eval_is_addUnordered (thmid:string) _ - (t as (Const("Poly.is'_addUnordered", _) $ arg)) thy = - if is_addUnordered arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.true_const))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.false_const))) - | eval_is_addUnordered _ _ _ _ = NONE; - -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; -fun init_state (_:term) = e_rrlsstate; -fun locate_rule (_:rule list list) (_:term) (_:rule) = - ([]:(rule * (term * term list)) list); -fun next_rule (_:rule list list) (_:term) = (NONE:rule option); -fun normal_form t = SOME (sort_monoms t,[]:term list); - -val order_add_ = - Rrls {id = "order_add_", - prepat = (*WN.18.6.03 Preconditions und Pattern, - die beide passen muessen, damit das Rrls angewandt wird*) - [([(term_of o the o (parse thy)) "p is_addUnordered"], - (term_of o the o (parse thy)) "?p" - (*WN.18.6.03 also KEIN pattern, dieses erzeugt nur das Environment - fuer die Evaluation der Precondition "p is_addUnordered"*))], - rew_ord = ("dummy_ord", dummy_ord), - erls = append_rls "e_rls-is_addUnordered" e_rls(*MG: poly_erls*) - [Calc ("Poly.is'_addUnordered", eval_is_addUnordered "") - (*WN.18.6.03 definiert in Poly.thy, - evaluiert prepat*)], - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - (*asm_thm=[],*) - scr=Rfuns {init_state = init_state, - normal_form = normal_form, - locate_rule = locate_rule, - next_rule = next_rule, - attach_form = attach_form}}; - -val order_add_rls_ = - Rls{id = "order_add_rls_", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Rls_ order_add_ - ], scr = EmptyScr}:rls; - -(*. see MG-DA.p.52ff .*) -val make_polynomial(*MG.03, overwrites version from above, - previously 'make_polynomial_'*) = - Seq {id = "make_polynomial", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls,calc = [], - rules = [Rls_ discard_minus_, - Rls_ expand_poly_, - Calc ("op *", eval_binop "#mult_"), - Rls_ order_mult_rls_, - Rls_ simplify_power_, - Rls_ calc_add_mult_pow_, - Rls_ reduce_012_mult_, - Rls_ order_add_rls_, - Rls_ collect_numerals_, - Rls_ reduce_012_, - Rls_ discard_parentheses_ - ], - scr = EmptyScr - }:rls; -val norm_Poly(*=make_polynomial*) = - Seq {id = "norm_Poly", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, calc = [], - rules = [Rls_ discard_minus_, - Rls_ expand_poly_, - Calc ("op *", eval_binop "#mult_"), - Rls_ order_mult_rls_, - Rls_ simplify_power_, - Rls_ calc_add_mult_pow_, - Rls_ reduce_012_mult_, - Rls_ order_add_rls_, - Rls_ collect_numerals_, - Rls_ reduce_012_, - Rls_ discard_parentheses_ - ], - scr = EmptyScr - }:rls; - -(* MG:03 Like make_polynomial_ but without Rls_ discard_parentheses_ - and expand_poly_rat_ instead of expand_poly_, see MG-DA.p.56ff*) -(* MG necessary for termination of norm_Rational(*_mg*) in Rational.ML*) -val make_rat_poly_with_parentheses = - Seq{id = "make_rat_poly_with_parentheses", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, calc = [], - rules = [Rls_ discard_minus_, - Rls_ expand_poly_rat_,(*ignors rationals*) - Calc ("op *", eval_binop "#mult_"), - Rls_ order_mult_rls_, - Rls_ simplify_power_, - Rls_ calc_add_mult_pow_, - Rls_ reduce_012_mult_, - Rls_ order_add_rls_, - Rls_ collect_numerals_, - Rls_ reduce_012_ - (*Rls_ discard_parentheses_ *) - ], - scr = EmptyScr - }:rls; - -(*.a minimal ruleset for reverse rewriting of factions [2]; - compare expand_binoms.*) -val rev_rew_p = -Seq{id = "reverse_rewriting", preconds = [], rew_ord = ("termlessI",termlessI), - erls = Atools_erls, srls = Erls, - calc = [(*("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_"))*) - ], - rules = [Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), - (*"(a + b)*(a + b) = a ^ 2 + 2 * a * b + b ^ 2*) - Thm ("real_plus_binom_times1" ,num_str real_plus_binom_times1), - (*"(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"*) - Thm ("real_plus_binom_times2" ,num_str real_plus_binom_times2), - (*"(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"*) - - Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*) - - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - - Thm ("real_mult_assoc", num_str real_mult_assoc), - (*"?z1.1 * ?z2.1 * ?z3. =1 ?z1.1 * (?z2.1 * ?z3.1)"*) - Rls_ order_mult_rls_, - (*Rls_ order_add_rls_,*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_"), - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> - l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Thm ("realpow_multI", num_str realpow_multI), - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_"), - - Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0),(*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left)(*0 + z = z*) - - (*Rls_ order_add_rls_*) - ], - - scr = EmptyScr}:rls; - -ruleset' := -overwritelthy thy (!ruleset', - [("norm_Poly", prep_rls norm_Poly), - ("Poly_erls",Poly_erls)(*FIXXXME:del with rls.rls'*), - ("expand", prep_rls expand), - ("expand_poly", prep_rls expand_poly), - ("simplify_power", prep_rls simplify_power), - ("order_add_mult", prep_rls order_add_mult), - ("collect_numerals", prep_rls collect_numerals), - ("collect_numerals_", prep_rls collect_numerals_), - ("reduce_012", prep_rls reduce_012), - ("discard_parentheses", prep_rls discard_parentheses), - ("make_polynomial", prep_rls make_polynomial), - ("expand_binoms", prep_rls expand_binoms), - ("rev_rew_p", prep_rls rev_rew_p), - ("discard_minus_", prep_rls discard_minus_), - ("expand_poly_", prep_rls expand_poly_), - ("expand_poly_rat_", prep_rls expand_poly_rat_), - ("simplify_power_", prep_rls simplify_power_), - ("calc_add_mult_pow_", prep_rls calc_add_mult_pow_), - ("reduce_012_mult_", prep_rls reduce_012_mult_), - ("reduce_012_", prep_rls reduce_012_), - ("discard_parentheses_",prep_rls discard_parentheses_), - ("order_mult_rls_", prep_rls order_mult_rls_), - ("order_add_rls_", prep_rls order_add_rls_), - ("make_rat_poly_with_parentheses", - prep_rls make_rat_poly_with_parentheses) - (*("", prep_rls ), - ("", prep_rls ), - ("", prep_rls ) - *) - ]); - -calclist':= overwritel (!calclist', - [("is_polyrat_in", ("Poly.is'_polyrat'_in", - eval_is_polyrat_in "#eval_is_polyrat_in")), - ("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in "")), - ("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in "")), - ("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in "")), - ("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp "")), - ("is_multUnordered", ("Poly.is'_multUnordered", eval_is_multUnordered"")), - ("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered "")) - ]); - - -(** problems **) - -store_pbt - (prep_pbt Poly.thy "pbl_simp_poly" [] e_pblID - (["polynomial","simplification"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*) - Calc ("Poly.is'_polyexp", eval_is_polyexp "")], - SOME "Simplify t_", - [["simplification","for_polynomials"]])); - - -(** methods **) - -store_met - (prep_met Poly.thy "met_simp_poly" [] e_metID - (["simplification","for_polynomials"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", - rls' = e_rls, - calc = [], - srls = e_rls, - prls = append_rls "simplification_for_polynomials_prls" e_rls - [(*for preds in where_*) - Calc ("Poly.is'_polyexp",eval_is_polyexp"")], - crls = e_rls, nrls = norm_Poly}, - "Script SimplifyScript (t_::real) = \ - \ ((Rewrite_Set norm_Poly False) t_)" - )); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Poly.thy --- a/src/Tools/isac/IsacKnowledge/Poly.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,147 +0,0 @@ -(* WN.020812: theorems in the Reals, - necessary for special rule sets, in addition to Isabelle2002. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! THIS IS THE _least_ NUMBER OF ADDITIONAL THEOREMS !!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - xxxI contain ^^^ instead of ^ in the respective theorem xxx in 2002 - changed by: Richard Lang 020912 -*) - -(* - use_thy"IsacKnowledge/Poly"; - use_thy"Poly"; - use_thy_only"IsacKnowledge/Poly"; - - remove_thy"Poly"; - use_thy"IsacKnowledge/Isac"; - - - use"ROOT.ML"; - cd"IsacKnowledge"; - *) - -Poly = Simplify + - -(*-------------------- consts-----------------------------------------------*) -consts - - is'_expanded'_in :: "[real, real] => bool" ("_ is'_expanded'_in _") - is'_poly'_in :: "[real, real] => bool" ("_ is'_poly'_in _") (*RL DA *) - has'_degree'_in :: "[real, real] => real" ("_ has'_degree'_in _")(*RL DA *) - is'_polyrat'_in :: "[real, real] => bool" ("_ is'_polyrat'_in _")(*RL030626*) - - is'_multUnordered :: "real => bool" ("_ is'_multUnordered") - is'_addUnordered :: "real => bool" ("_ is'_addUnordered") (*WN030618*) - is'_polyexp :: "real => bool" ("_ is'_polyexp") - - Expand'_binoms - :: "['y, \ - \ 'y] => 'y" - ("((Script Expand'_binoms (_ =))// \ - \ (_))" 9) - -(*-------------------- rules------------------------------------------------*) -rules (*.not contained in Isabelle2002, - stated as axioms, TODO: prove as theorems; - theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*) - - realpow_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)" - realpow_addI "r ^^^ (n + m) = r ^^^ n * r ^^^ m" - realpow_addI_assoc_l "r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s" - realpow_addI_assoc_r "s * r ^^^ n * r ^^^ m = s * r ^^^ (n + m)" - - realpow_oneI "r ^^^ 1 = r" - realpow_zeroI "r ^^^ 0 = 1" - realpow_eq_oneI "1 ^^^ n = 1" - realpow_multI "(r * s) ^^^ n = r ^^^ n * s ^^^ n" - realpow_multI_poly "[| r is_polyexp; s is_polyexp |] ==> \ - \(r * s) ^^^ n = r ^^^ n * s ^^^ n" - realpow_minus_oneI "-1 ^^^ (2 * n) = 1" - - realpow_twoI "r ^^^ 2 = r * r" - realpow_twoI_assoc_l "r * (r * s) = r ^^^ 2 * s" - realpow_twoI_assoc_r "s * r * r = s * r ^^^ 2" - realpow_two_atom "r is_atom ==> r * r = r ^^^ 2" - realpow_plus_1 "r * r ^^^ n = r ^^^ (n + 1)" - realpow_plus_1_assoc_l "r * (r ^^^ m * s) = r ^^^ (1 + m) * s" - realpow_plus_1_assoc_l2 "r ^^^ m * (r * s) = r ^^^ (1 + m) * s" - realpow_plus_1_assoc_r "s * r * r ^^^ m = s * r ^^^ (1 + m)" - realpow_plus_1_atom "r is_atom ==> r * r ^^^ n = r ^^^ (1 + n)" - realpow_def_atom "[| Not (r is_atom); 1 < n |] \ - \ ==> r ^^^ n = r * r ^^^ (n + -1)" - realpow_addI_atom "r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)" - - - realpow_minus_even "n is_even ==> (- r) ^^^ n = r ^^^ n" - realpow_minus_odd "Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n" - - -(* RL 020914 *) - real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d" - real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d" - real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d" - real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d" - real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" - real_plus_binom_pow3_poly "[| a is_polyexp; b is_polyexp |] ==> \ - \(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" - real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3" - real_minus_binom_pow3_p "(a + -1 * b)^^^3 = a^^^3 + -3*a^^^2*b + 3*a*b^^^2 + -1*b^^^3" -(* real_plus_binom_pow "[| n is_const; 3 < n |] ==> \ - \(a + b)^^^n = (a + b) * (a + b)^^^(n - 1)" *) - real_plus_binom_pow4 "(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)" - real_plus_binom_pow4_poly "[| a is_polyexp; b is_polyexp |] ==> \ - \(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)" - 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)" - - real_plus_binom_pow5_poly "[| a is_polyexp; b is_polyexp |] ==> \ - \(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)" - - real_diff_plus "a - b = a + -b" (*17.3.03: do_NOT_use*) - real_diff_minus "a - b = a + -1 * b" - real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2" - real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2" - (*WN071229 changed for Schaerding -----vvv*) - (*real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) - real_plus_binom_pow2 "(a + b)^^^2 = (a + b) * (a + b)" - (*WN071229 changed for Schaerding -----^^^*) - real_plus_binom_pow2_poly "[| a is_polyexp; b is_polyexp |] ==> \ - \(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2" - real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2" - real_minus_binom_pow2_p "(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2" - real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2" - real_plus_minus_binom1_p "(a + b)*(a - b) = a^^^2 + -1*b^^^2" - real_plus_minus_binom1_p_p "(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2" - real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2" - real_plus_minus_binom2_p "(a - b)*(a + b) = a^^^2 + -1*b^^^2" - real_plus_minus_binom2_p_p "(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2" - real_plus_binom_times1 "(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2" - real_plus_binom_times2 "(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2" - - real_num_collect "[| l is_const; m is_const |] ==> \ - \l * n + m * n = (l + m) * n" -(* FIXME.MG.0401: replace 'real_num_collect_assoc' - by 'real_num_collect_assoc_l' ... are equal, introduced by MG ! *) - real_num_collect_assoc "[| l is_const; m is_const |] ==> \ - \l * n + (m * n + k) = (l + m) * n + k" - real_num_collect_assoc_l "[| l is_const; m is_const |] ==> \ - \l * n + (m * n + k) = (l + m) - * n + k" - real_num_collect_assoc_r "[| l is_const; m is_const |] ==> \ - \(k + m * n) + l * n = k + (l + m) * n" - real_one_collect "m is_const ==> n + m * n = (1 + m) * n" -(* FIXME.MG.0401: replace 'real_one_collect_assoc' - by 'real_one_collect_assoc_l' ... are equal, introduced by MG ! *) - real_one_collect_assoc "m is_const ==> n + (m * n + k) = (1 + m)* n + k" - - real_one_collect_assoc_l "m is_const ==> n + (m * n + k) = (1 + m) * n + k" - real_one_collect_assoc_r "m is_const ==>(k + n) + m * n = k + (1 + m) * n" - -(* FIXME.MG.0401: replace 'real_mult_2_assoc' - by 'real_mult_2_assoc_l' ... are equal, introduced by MG ! *) - real_mult_2_assoc "z1 + (z1 + k) = 2 * z1 + k" - real_mult_2_assoc_l "z1 + (z1 + k) = 2 * z1 + k" - real_mult_2_assoc_r "(k + z1) + z1 = k + 2 * z1" - - real_add_mult_distrib_poly "w is_polyexp ==> (z1 + z2) * w = z1 * w + z2 * w" - real_add_mult_distrib2_poly "w is_polyexp ==> w * (z1 + z2) = w * z1 + w * z2" -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/PolyEq.ML --- a/src/Tools/isac/IsacKnowledge/PolyEq.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1162 +0,0 @@ -(*. (c) by Richard Lang, 2003 .*) -(* collecting all knowledge for PolynomialEquations - created by: rlang - date: 02.07 - changed by: rlang - last change by: rlang - date: 02.11.26 -*) - -(* use"IsacKnowledge/PolyEq.ML"; - use"PolyEq.ML"; - - use"ROOT.ML"; - cd"IsacKnowledge"; - - remove_thy"PolyEq"; - use_thy"IsacKnowledge/Isac"; - *) -"******* PolyEq.ML begin *******"; - -theory' := overwritel (!theory', [("PolyEq.thy",PolyEq.thy)]); -(*-------------------------functions---------------------*) -(* just for try -local - fun add0 l d d_ = if (d_+1) < d then add0 (str2term"0"::l) d (d_+1) else l; - fun poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("Atools.pow",_) $ v_ $ Free (d_,_)))) v l d = - if (v=v_) - then poly2list_ t1 v (((str2term("1")))::(add0 l d (int_of_str' d_))) (int_of_str' d_) - else t::(add0 l d 0) - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ - (Const ("Atools.pow",_) $ v_ $ Free (d_,_))))) v l d = - if (v=v_) - then poly2list_ t1 v (((t11))::(add0 l d (int_of_str' d_))) (int_of_str' d_) - else t::(add0 l d 0) - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Free (v_ , _)) )) v l d = - if (v = (str2term v_)) - then poly2list_ t1 v (((str2term("1")))::(add0 l d 1 )) 1 - else t::(add0 l d 0) - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ (Free (v_,_)) ))) v l d = - if (v= (str2term v_)) - then poly2list_ t1 v ( (t11)::(add0 l d 1 )) 1 - else t::(add0 l d 0) - | poly2list_ (t as (Const ("op +",_) $ _ $ _))_ l d = t::(add0 l d 0) - | poly2list_ (t as (Free (_,_))) _ l d = t::(add0 l d 0) - | poly2list_ t _ l d = t::(add0 l d 0); - - fun poly2list t v = poly2list_ t v [] 0; - fun diffpolylist_ [] _ = [] - | diffpolylist_ (x::xs) d = (str2term (if term2str(x)="0" - then "0" - else term2str(x)^"*"^str_of_int(d)))::diffpolylist_ xs (d+1); - fun diffpolylist [] = [] - | diffpolylist (x::xs) = diffpolylist_ xs 1; - (* diffpolylist(poly2list (str2term "1+ x +3*x^^^3") (str2term "x"));*) -in - -end; -*) -(*-------------------------rulse-------------------------*) -val PolyEq_prls = (*3.10.02:just the following order due to subterm evaluation*) - append_rls "PolyEq_prls" e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Tools.lhs" ,eval_lhs ""), - Calc ("Tools.rhs" ,eval_rhs ""), - Calc ("Poly.is'_expanded'_in",eval_is_expanded_in ""), - Calc ("Poly.is'_poly'_in",eval_is_poly_in ""), - Calc ("Poly.has'_degree'_in",eval_has_degree_in ""), - Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""), - (*Calc ("Atools.occurs'_in",eval_occurs_in ""), *) - (*Calc ("Atools.is'_const",eval_const "#is_const_"),*) - Calc ("op =",eval_equal "#equal_"), - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), - Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false), - Thm ("or_true",num_str or_true), - Thm ("or_false",num_str or_false) - ]; - -val PolyEq_erls = - merge_rls "PolyEq_erls" LinEq_erls - (append_rls "ops_preds" calculate_Rational - [Calc ("op =",eval_equal "#equal_"), - Thm ("plus_leq", num_str plus_leq), - Thm ("minus_leq", num_str minus_leq), - Thm ("rat_leq1", num_str rat_leq1), - Thm ("rat_leq2", num_str rat_leq2), - Thm ("rat_leq3", num_str rat_leq3) - ]); - -val PolyEq_crls = - merge_rls "PolyEq_crls" LinEq_crls - (append_rls "ops_preds" calculate_Rational - [Calc ("op =",eval_equal "#equal_"), - Thm ("plus_leq", num_str plus_leq), - Thm ("minus_leq", num_str minus_leq), - Thm ("rat_leq1", num_str rat_leq1), - Thm ("rat_leq2", num_str rat_leq2), - Thm ("rat_leq3", num_str rat_leq3) - ]); -(*------ -val PolyEq_erls = - merge_rls "PolyEq_erls" - (append_rls "" (Rls {(*asm_thm=[],*)calc=[], - erls= Rls {(*asm_thm=[],*)calc=[], - erls= Erls, - id="e_rls",preconds=[], - rew_ord=("dummy_ord",dummy_ord), - rules=[Thm ("", - num_str ), - Thm ("", - num_str ), - Thm ("", - num_str ) - ], - scr=EmptyScr,srls=Erls}, - id="e_rls",preconds=[],rew_ord=("dummy_ord", - dummy_ord), - rules=[],scr=EmptyScr,srls=Erls} - ) - ((#rules o rep_rls) LinEq_erls)) - (append_rls "ops_preds" calculate_Rational - [Calc ("op =",eval_equal "#equal_"), - Thm ("plus_leq", num_str plus_leq), - Thm ("minus_leq", num_str minus_leq), - Thm ("rat_leq1", num_str rat_leq1), - Thm ("rat_leq2", num_str rat_leq2), - Thm ("rat_leq3", num_str rat_leq3) - ]); ------*) - - -val cancel_leading_coeff = prep_rls( - Rls {id = "cancel_leading_coeff", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("cancel_leading_coeff1",num_str cancel_leading_coeff1), - Thm ("cancel_leading_coeff2",num_str cancel_leading_coeff2), - Thm ("cancel_leading_coeff3",num_str cancel_leading_coeff3), - Thm ("cancel_leading_coeff4",num_str cancel_leading_coeff4), - Thm ("cancel_leading_coeff5",num_str cancel_leading_coeff5), - Thm ("cancel_leading_coeff6",num_str cancel_leading_coeff6), - Thm ("cancel_leading_coeff7",num_str cancel_leading_coeff7), - Thm ("cancel_leading_coeff8",num_str cancel_leading_coeff8), - Thm ("cancel_leading_coeff9",num_str cancel_leading_coeff9), - Thm ("cancel_leading_coeff10",num_str cancel_leading_coeff10), - Thm ("cancel_leading_coeff11",num_str cancel_leading_coeff11), - Thm ("cancel_leading_coeff12",num_str cancel_leading_coeff12), - Thm ("cancel_leading_coeff13",num_str cancel_leading_coeff13) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -val complete_square = prep_rls( - Rls {id = "complete_square", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("complete_square1",num_str complete_square1), - Thm ("complete_square2",num_str complete_square2), - Thm ("complete_square3",num_str complete_square3), - Thm ("complete_square4",num_str complete_square4), - Thm ("complete_square5",num_str complete_square5) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("cancel_leading_coeff",cancel_leading_coeff), - ("complete_square",complete_square), - ("PolyEq_erls",PolyEq_erls)(*FIXXXME:del with rls.rls'*) - ]); -val polyeq_simplify = prep_rls( - Rls {id = "polyeq_simplify", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_assoc_1",num_str real_assoc_1), - Thm ("real_assoc_2",num_str real_assoc_2), - Thm ("real_diff_minus",num_str real_diff_minus), - Thm ("real_unari_minus",num_str real_unari_minus), - Thm ("realpow_multI",num_str realpow_multI), - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - Rls_ reduce_012 - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("polyeq_simplify",polyeq_simplify)]); - - -(* ------------- polySolve ------------------ *) -(* -- d0 -- *) -(*isolate the bound variable in an d0 equation; 'bdv' is a meta-constant*) -val d0_polyeq_simplify = prep_rls( - Rls {id = "d0_polyeq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm("d0_true",num_str d0_true), - Thm("d0_false",num_str d0_false) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* -- d1 -- *) -(*isolate the bound variable in an d1 equation; 'bdv' is a meta-constant*) -val d1_polyeq_simplify = prep_rls( - Rls {id = "d1_polyeq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d1_isolate_div","")],*) - rules = [ - Thm("d1_isolate_add1",num_str d1_isolate_add1), - (* a+bx=0 -> bx=-a *) - Thm("d1_isolate_add2",num_str d1_isolate_add2), - (* a+ x=0 -> x=-a *) - Thm("d1_isolate_div",num_str d1_isolate_div) - (* bx=c -> x=c/b *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* -- d2 -- *) -(*isolate the bound variable in an d2 equation with bdv only; 'bdv' is a meta-constant*) -val d2_polyeq_bdv_only_simplify = prep_rls( - Rls {id = "d2_polyeq_bdv_only_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), - ("d2_isolate_div","")],*) - rules = [ - Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *) - Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *) - Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *) - Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *) - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg), (* [0 [] *) - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) - Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*) - Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*) - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(*isolate the bound variable in an d2 equation with sqrt only; 'bdv' is a meta-constant*) -val d2_polyeq_sq_only_simplify = prep_rls( - Rls {id = "d2_polyeq_sq_only_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), - ("d2_isolate_div","")],*) - rules = [ - Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*) - Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*) - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[] *) - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(*isolate the bound variable in an d2 equation with pqFormula; 'bdv' is a meta-constant*) -val d2_polyeq_pqFormula_simplify = prep_rls( - Rls {id = "d2_polyeq_pqFormula_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), - ("d2_pqformula5",""),("d2_pqformula6",""),("d2_pqformula7",""),("d2_pqformula8",""), - ("d2_pqformula9",""),("d2_pqformula10",""), - ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), - ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),("d2_pqformula10_neg","")],*) - rules = [ - Thm("d2_pqformula1",num_str d2_pqformula1), (* q+px+ x^2=0 *) - Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* q+px+ x^2=0 *) - Thm("d2_pqformula2",num_str d2_pqformula2), (* q+px+1x^2=0 *) - Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* q+px+1x^2=0 *) - Thm("d2_pqformula3",num_str d2_pqformula3), (* q+ x+ x^2=0 *) - Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* q+ x+ x^2=0 *) - Thm("d2_pqformula4",num_str d2_pqformula4), (* q+ x+1x^2=0 *) - Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* q+ x+1x^2=0 *) - Thm("d2_pqformula5",num_str d2_pqformula5), (* qx+ x^2=0 *) - Thm("d2_pqformula6",num_str d2_pqformula6), (* qx+1x^2=0 *) - Thm("d2_pqformula7",num_str d2_pqformula7), (* x+ x^2=0 *) - Thm("d2_pqformula8",num_str d2_pqformula8), (* x+1x^2=0 *) - Thm("d2_pqformula9",num_str d2_pqformula9), (* q +1x^2=0 *) - Thm("d2_pqformula9_neg",num_str d2_pqformula9_neg), (* q +1x^2=0 *) - Thm("d2_pqformula10",num_str d2_pqformula10), (* q + x^2=0 *) - Thm("d2_pqformula10_neg",num_str d2_pqformula10_neg), (* q + x^2=0 *) - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *) - Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* 1x^2=0 *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(*isolate the bound variable in an d2 equation with abcFormula; 'bdv' is a meta-constant*) -val d2_polyeq_abcFormula_simplify = prep_rls( - Rls {id = "d2_polyeq_abcFormula_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""), - ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""), - ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""), - ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), - ("d2_abcformula3_neg",""),("d2_abcformula4_neg",""),("d2_abcformula5_neg",""), - ("d2_abcformula6_neg","")],*) - rules = [ - Thm("d2_abcformula1",num_str d2_abcformula1), (*c+bx+cx^2=0 *) - Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (*c+bx+cx^2=0 *) - Thm("d2_abcformula2",num_str d2_abcformula2), (*c+ x+cx^2=0 *) - Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (*c+ x+cx^2=0 *) - Thm("d2_abcformula3",num_str d2_abcformula3), (*c+bx+ x^2=0 *) - Thm("d2_abcformula3_neg",num_str d2_abcformula3_neg), (*c+bx+ x^2=0 *) - Thm("d2_abcformula4",num_str d2_abcformula4), (*c+ x+ x^2=0 *) - Thm("d2_abcformula4_neg",num_str d2_abcformula4_neg), (*c+ x+ x^2=0 *) - Thm("d2_abcformula5",num_str d2_abcformula5), (*c+ cx^2=0 *) - Thm("d2_abcformula5_neg",num_str d2_abcformula5_neg), (*c+ cx^2=0 *) - Thm("d2_abcformula6",num_str d2_abcformula6), (*c+ x^2=0 *) - Thm("d2_abcformula6_neg",num_str d2_abcformula6_neg), (*c+ x^2=0 *) - Thm("d2_abcformula7",num_str d2_abcformula7), (* bx+ax^2=0 *) - Thm("d2_abcformula8",num_str d2_abcformula8), (* bx+ x^2=0 *) - Thm("d2_abcformula9",num_str d2_abcformula9), (* x+ax^2=0 *) - Thm("d2_abcformula10",num_str d2_abcformula10), (* x+ x^2=0 *) - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *) - Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* bx^2=0 *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(*isolate the bound variable in an d2 equation; 'bdv' is a meta-constant*) -val d2_polyeq_simplify = prep_rls( - Rls {id = "d2_polyeq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), - ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), - ("d2_pqformula4_neg",""), - ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""), - ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""), - ("d2_sqrt_equation1_neg",""),("d2_isolate_div","")],*) - rules = [ - Thm("d2_pqformula1",num_str d2_pqformula1), (* p+qx+ x^2=0 *) - Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* p+qx+ x^2=0 *) - Thm("d2_pqformula2",num_str d2_pqformula2), (* p+qx+1x^2=0 *) - Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* p+qx+1x^2=0 *) - Thm("d2_pqformula3",num_str d2_pqformula3), (* p+ x+ x^2=0 *) - Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* p+ x+ x^2=0 *) - Thm("d2_pqformula4",num_str d2_pqformula4), (* p+ x+1x^2=0 *) - Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* p+ x+1x^2=0 *) - Thm("d2_abcformula1",num_str d2_abcformula1), (* c+bx+cx^2=0 *) - Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (* c+bx+cx^2=0 *) - Thm("d2_abcformula2",num_str d2_abcformula2), (* c+ x+cx^2=0 *) - Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (* c+ x+cx^2=0 *) - Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *) - Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *) - Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *) - Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *) - Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*) - Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*) - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[]*) - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) - Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*) - Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*) - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* -- d3 -- *) -(*isolate the bound variable in an d3 equation; 'bdv' is a meta-constant*) -val d3_polyeq_simplify = prep_rls( - Rls {id = "d3_polyeq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [("d3_isolate_div","")],*) - rules = [ - Thm("d3_reduce_equation1",num_str d3_reduce_equation1), - (*a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation2",num_str d3_reduce_equation2), - (* bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation3",num_str d3_reduce_equation3), - (*a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation4",num_str d3_reduce_equation4), - (* bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation5",num_str d3_reduce_equation5), - (*a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0)*) - Thm("d3_reduce_equation6",num_str d3_reduce_equation6), - (* bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0)*) - Thm("d3_reduce_equation7",num_str d3_reduce_equation7), - (*a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*) - Thm("d3_reduce_equation8",num_str d3_reduce_equation8), - (* bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*) - Thm("d3_reduce_equation9",num_str d3_reduce_equation9), - (*a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0)*) - Thm("d3_reduce_equation10",num_str d3_reduce_equation10), - (* bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0)*) - Thm("d3_reduce_equation11",num_str d3_reduce_equation11), - (*a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0)*) - Thm("d3_reduce_equation12",num_str d3_reduce_equation12), - (* bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0)*) - Thm("d3_reduce_equation13",num_str d3_reduce_equation13), - (* b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation14",num_str d3_reduce_equation14), - (* bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0)*) - Thm("d3_reduce_equation15",num_str d3_reduce_equation15), - (* b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0)*) - Thm("d3_reduce_equation16",num_str d3_reduce_equation16), - (* bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0)*) - Thm("d3_isolate_add1",num_str d3_isolate_add1), - (*[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (bdv=0 | (b*bdv^^^3=a)*) - Thm("d3_isolate_add2",num_str d3_isolate_add2), - (*[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = (bdv=0 | ( bdv^^^3=a)*) - Thm("d3_isolate_div",num_str d3_isolate_div), - (*[|Not(b=0)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b*) - Thm("d3_root_equation2",num_str d3_root_equation2), - (*(bdv^^^3=0) = (bdv=0) *) - Thm("d3_root_equation1",num_str d3_root_equation1) - (*bdv^^^3=c) = (bdv = nroot 3 c*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* -- d4 -- *) -(*isolate the bound variable in an d4 equation; 'bdv' is a meta-constant*) -val d4_polyeq_simplify = prep_rls( - Rls {id = "d4_polyeq_simplify", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = PolyEq_erls, - srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm("d4_sub_u1",num_str d4_sub_u1) - (* ax^4+bx^2+c=0 -> x=+-sqrt(ax^2+bx^+c) *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); - -ruleset' := overwritelthy thy (!ruleset', - [("d0_polyeq_simplify", d0_polyeq_simplify), - ("d1_polyeq_simplify", d1_polyeq_simplify), - ("d2_polyeq_simplify", d2_polyeq_simplify), - ("d2_polyeq_bdv_only_simplify", d2_polyeq_bdv_only_simplify), - ("d2_polyeq_sq_only_simplify", d2_polyeq_sq_only_simplify), - ("d2_polyeq_pqFormula_simplify", d2_polyeq_pqFormula_simplify), - ("d2_polyeq_abcFormula_simplify", d2_polyeq_abcFormula_simplify), - ("d3_polyeq_simplify", d3_polyeq_simplify), - ("d4_polyeq_simplify", d4_polyeq_simplify) - ]); - -(*------------------------problems------------------------*) -(* -(get_pbt ["degree_2","polynomial","univariate","equation"]); -show_ptyps(); -*) - -(*-------------------------poly-----------------------*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly" [] e_pblID - (["polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["~((e_::bool) is_ratequation_in (v_::real))", - "~((lhs e_) is_rootTerm_in (v_::real))", - "~((rhs e_) is_rootTerm_in (v_::real))"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [])); -(*--- d0 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg0" [] e_pblID - (["degree_0","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_poly_in v_", - "((lhs e_) has_degree_in v_ ) = 0" - ]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d0_polyeq_equation"]])); - -(*--- d1 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg1" [] e_pblID - (["degree_1","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_poly_in v_", - "((lhs e_) has_degree_in v_ ) = 1" - ]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d1_polyeq_equation"]])); - -(*--- d2 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2" [] e_pblID - (["degree_2","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_ ) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d2_polyeq_equation"]])); - - store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_sqonly" [] e_pblID - (["sq_only","degree_2","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches ( ?a + ?v_^^^2 = 0) e_ | \ - \matches ( ?a + ?b*?v_^^^2 = 0) e_ | \ - \matches ( ?v_^^^2 = 0) e_ | \ - \matches ( ?b*?v_^^^2 = 0) e_" , - "Not (matches (?a + ?v_ + ?v_^^^2 = 0) e_) &\ - \Not (matches (?a + ?b*?v_ + ?v_^^^2 = 0) e_) &\ - \Not (matches (?a + ?v_ + ?c*?v_^^^2 = 0) e_) &\ - \Not (matches (?a + ?b*?v_ + ?c*?v_^^^2 = 0) e_) &\ - \Not (matches ( ?v_ + ?v_^^^2 = 0) e_) &\ - \Not (matches ( ?b*?v_ + ?v_^^^2 = 0) e_) &\ - \Not (matches ( ?v_ + ?c*?v_^^^2 = 0) e_) &\ - \Not (matches ( ?b*?v_ + ?c*?v_^^^2 = 0) e_)"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d2_polyeq_sqonly_equation"]])); - -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_bdvonly" [] e_pblID - (["bdv_only","degree_2","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a*?v_ + ?v_^^^2 = 0) e_ | \ - \matches ( ?v_ + ?v_^^^2 = 0) e_ | \ - \matches ( ?v_ + ?b*?v_^^^2 = 0) e_ | \ - \matches (?a*?v_ + ?b*?v_^^^2 = 0) e_ | \ - \matches ( ?v_^^^2 = 0) e_ | \ - \matches ( ?b*?v_^^^2 = 0) e_ "]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d2_polyeq_bdvonly_equation"]])); - -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_pq" [] e_pblID - (["pqFormula","degree_2","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a + 1*?v_^^^2 = 0) e_ | \ - \matches (?a + ?v_^^^2 = 0) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d2_polyeq_pq_equation"]])); - -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_abc" [] e_pblID - (["abcFormula","degree_2","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a + ?v_^^^2 = 0) e_ | \ - \matches (?a + ?b*?v_^^^2 = 0) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d2_polyeq_abc_equation"]])); - -(*--- d3 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg3" [] e_pblID - (["degree_3","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 3"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","solve_d3_polyeq_equation"]])); - -(*--- d4 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg4" [] e_pblID - (["degree_4","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 4"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [(*["PolyEq","solve_d4_polyeq_equation"]*)])); - -(*--- normalize ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_norm" [] e_pblID - (["normalize","polynomial","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\ - \(Not(((lhs e_) is_poly_in v_)))"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","normalize_poly"]])); -(*-------------------------expanded-----------------------*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_expand" [] e_pblID - (["expanded","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "(lhs e_) is_expanded_in v_ "]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [])); - -(*--- d2 ---*) -store_pbt - (prep_pbt PolyEq.thy "pbl_equ_univ_expand_deg2" [] e_pblID - (["degree_2","expanded","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - PolyEq_prls, SOME "solve (e_::bool, v_)", - [["PolyEq","complete_square"]])); - - -"-------------------------methods-----------------------"; -store_met - (prep_met PolyEq.thy "met_polyeq" [] e_metID - (["PolyEq"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=PolyEq_crls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); - -store_met - (prep_met PolyEq.thy "met_polyeq_norm" [] e_metID - (["PolyEq","normalize_poly"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\ - \(Not(((lhs e_) is_poly_in v_)))"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[], - crls=PolyEq_crls, nrls=norm_Rational(*, - asm_rls=[], - asm_thm=[]*)}, - (*RL: Ratpoly loest Brueche ohne bdv*) - "Script Normalize_poly (e_::bool) (v_::real) = \ - \(let e_ =((Try (Rewrite all_left False)) @@ \ - \ (Try (Repeat (Rewrite makex1_x False))) @@ \ - \ (Try (Repeat (Rewrite_Set expand_binoms False))) @@ \ - \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ make_ratpoly_in False))) @@ \ - \ (Try (Repeat (Rewrite_Set polyeq_simplify False)))) e_ \ - \ in (SubProblem (PolyEq_,[polynomial,univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_]))" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d0" [] e_metID - (["PolyEq","solve_d0_polyeq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 0"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - asm_rls=[], - asm_thm=[]*)}, - "Script Solve_d0_polyeq_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d0_polyeq_simplify False))) e_ \ - \ in ((Or_to_List e_)::bool list))" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d1" [] e_metID - (["PolyEq","solve_d1_polyeq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 1"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (* asm_rls=["d1_polyeq_simplify"],*) - asm_rls=[], - asm_thm=[("d1_isolate_div","")]*)}, - "Script Solve_d1_polyeq_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d1_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d22" [] e_metID - (["PolyEq","solve_d2_polyeq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (*asm_rls=["d2_polyeq_simplify","d1_polyeq_simplify"],*) - asm_rls=[], - asm_thm = [("d1_isolate_div",""),("d2_pqformula1",""),("d2_pqformula2",""), - ("d2_pqformula3",""),("d2_pqformula4",""),("d2_pqformula1_neg",""), - ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),("d2_pqformula4_neg",""), - ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""), - ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""), - ("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)}, - "Script Solve_d2_polyeq_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d1_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d2_bdvonly" [] e_metID - (["PolyEq","solve_d2_polyeq_bdvonly_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (*asm_rls=["d2_polyeq_bdv_only_simplify","d1_polyeq_simplify "],*) - asm_rls=[], - asm_thm=[("d1_isolate_div",""),("d2_isolate_div",""), - ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg","")]*)}, - "Script Solve_d2_polyeq_bdvonly_equation (e_::bool) (v_::real) =\ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_bdv_only_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d1_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d2_sqonly" [] e_metID - (["PolyEq","solve_d2_polyeq_sqonly_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (*asm_rls=["d2_polyeq_sq_only_simplify"],*) - asm_rls=[], - asm_thm=[("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), - ("d2_isolate_div","")]*)}, - "Script Solve_d2_polyeq_sqonly_equation (e_::bool) (v_::real) =\ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_sq_only_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_; \ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d2_pq" [] e_metID - (["PolyEq","solve_d2_polyeq_pq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (*asm_rls=["d2_polyeq_pqFormula_simplify"],*) - asm_rls=[], - asm_thm=[("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""), - ("d2_pqformula4",""),("d2_pqformula5",""),("d2_pqformula6",""), - ("d2_pqformula7",""),("d2_pqformula8",""),("d2_pqformula9",""), - ("d2_pqformula10",""),("d2_pqformula1_neg",""),("d2_pqformula2_neg",""), - ("d2_pqformula3_neg",""), ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""), - ("d2_pqformula10_neg","")]*)}, - "Script Solve_d2_polyeq_pq_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_pqFormula_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d2_abc" [] e_metID - (["PolyEq","solve_d2_polyeq_abc_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (*asm_rls=["d2_polyeq_abcFormula_simplify"],*) - asm_rls=[], - asm_thm=[("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""), - ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""), - ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""), - ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), - ("d2_abcformula3_neg",""), ("d2_abcformula4_neg",""),("d2_abcformula5_neg",""), - ("d2_abcformula6_neg","")]*)}, - "Script Solve_d2_polyeq_abc_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_abcFormula_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - -store_met - (prep_met PolyEq.thy "met_polyeq_d3" [] e_metID - (["PolyEq","solve_d3_polyeq_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_poly_in v_ ", - "((lhs e_) has_degree_in v_) = 3"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=PolyEq_erls, - srls=e_rls, - prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - (* asm_rls=["d1_polyeq_simplify","d2_polyeq_simplify","d1_polyeq_simplify"],*) - asm_rls=[], - asm_thm=[("d3_isolate_div",""),("d1_isolate_div",""),("d2_pqformula1",""), - ("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), - ("d2_pqformula1_neg",""), ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), - ("d2_pqformula4_neg",""), ("d2_abcformula1",""),("d2_abcformula2",""), - ("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), - ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)}, - "Script Solve_d3_polyeq_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d3_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d2_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ - \ d1_polyeq_simplify True)) @@ \ - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ - \ (L_::bool list) = ((Or_to_List e_)::bool list) \ - \ in Check_elementwise L_ {(v_::real). Assumptions} )" - )); - - (*.solves all expanded (ie. normalized) terms of degree 2.*) - (*Oct.02 restriction: 'eval_true 0 =< discriminant' ony for integer values - by 'PolyEq_erls'; restricted until Float.thy is implemented*) -store_met - (prep_met PolyEq.thy "met_polyeq_complsq" [] e_metID - (["PolyEq","complete_square"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = 0) e_", - "((lhs e_) has_degree_in v_) = 2"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls, - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], - crls=PolyEq_crls, nrls=norm_Rational(*, - asm_rls=[], - asm_thm=[("root_plus_minus","")]*)}, - "Script Complete_square (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\ - \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \ - \ @@ (Try (Rewrite square_explicit1 False)) \ - \ @@ (Try (Rewrite square_explicit2 False)) \ - \ @@ (Rewrite root_plus_minus True) \ - \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False))) \ - \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \ - \ @@ (Try (Repeat \ - \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \ - \ @@ (Try (Rewrite_Set calculate_RootRat False)) \ - \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \ - \ in ((Or_to_List e_)::bool list))" - )); -(*6.10.02: x^2=64: root_plus_minus -/-/-> - "Script Complete_square (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\ - \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \ - \ @@ (Try ((Rewrite square_explicit1 False) \ - \ Or (Rewrite square_explicit2 False))) \ - \ @@ (Rewrite root_plus_minus True) \ - \ @@ ((Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False)) \ - \ Or (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \ - \ @@ (Try (Repeat \ - \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \ - \ @@ (Try (Rewrite_Set calculate_RootRat False)) \ - \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \ - \ in ((Or_to_List e_)::bool list))"*) - -"******* PolyEq.ML end *******"; - -(*eine gehackte termorder*) -local (*. for make_polynomial_in .*) - -open Term; (* for type order = EQUAL | LESS | GREATER *) - -fun pr_ord EQUAL = "EQUAL" - | pr_ord LESS = "LESS" - | pr_ord GREATER = "GREATER"; - -fun dest_hd' x (Const (a, T)) = (((a, 0), T), 0) - | dest_hd' x (t as Free (a, T)) = - if x = t then ((("|||||||||||||", 0), T), 0) (*WN*) - else (((a, 0), T), 1) - | dest_hd' x (Var v) = (v, 2) - | dest_hd' x (Bound i) = ((("", i), dummyT), 3) - | dest_hd' x (Abs (_, T, _)) = ((("", 0), T), 4); - -fun size_of_term' x (Const ("Atools.pow",_) $ Free (var,_) $ Free (pot,_)) = - (case x of (*WN*) - (Free (xstr,_)) => - (if xstr = var then 1000*(the (int_of_str pot)) else 3) - | _ => raise error ("size_of_term' called with subst = "^ - (term2str x))) - | size_of_term' x (Free (subst,_)) = - (case x of - (Free (xstr,_)) => (if xstr = subst then 1000 else 1) - | _ => raise error ("size_of_term' called with subst = "^ - (term2str x))) - | size_of_term' x (Abs (_,_,body)) = 1 + size_of_term' x body - | size_of_term' x (f$t) = size_of_term' x f + size_of_term' x t - | size_of_term' x _ = 1; - - -fun term_ord' x pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) - (case term_ord' x pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) - | term_ord' x pr thy (t, u) = - (if pr then - let - val (f, ts) = strip_comb t and (g, us) = strip_comb u; - val _=writeln("t= f@ts= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ - (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\""); - val _=writeln("u= g@us= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ - (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\""); - val _=writeln("size_of_term(t,u)= ("^ - (string_of_int(size_of_term' x t))^", "^ - (string_of_int(size_of_term' x u))^")"); - val _=writeln("hd_ord(f,g) = "^((pr_ord o (hd_ord x))(f,g))); - val _=writeln("terms_ord(ts,us) = "^ - ((pr_ord o (terms_ord x) str false)(ts,us))); - val _=writeln("-------"); - in () end - else (); - case int_ord (size_of_term' x t, size_of_term' x u) of - EQUAL => - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in - (case hd_ord x (f, g) of EQUAL => (terms_ord x str pr) (ts, us) - | ord => ord) - end - | ord => ord) -and hd_ord x (f, g) = (* ~ term.ML *) - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' x f, - dest_hd' x g) -and terms_ord x str pr (ts, us) = - list_ord (term_ord' x pr (assoc_thy "Isac.thy"))(ts, us); -(*val x = (term_of o the o (parse thy)) "x"; (*FIXXXXXXME*) -*) - -in - -fun ord_make_polynomial_in (pr:bool) thy subst tu = - let - (* val _=writeln("*** subs variable is: "^(subst2str subst)); *) - in - case subst of - (_,x)::_ => (term_ord' x pr thy tu = LESS) - | _ => raise error ("ord_make_polynomial_in called with subst = "^ - (subst2str subst)) - end; -end; - -val order_add_mult_in = prep_rls( - Rls{id = "order_add_mult_in", preconds = [], - rew_ord = ("ord_make_polynomial_in", - ord_make_polynomial_in false Poly.thy), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_mult_commute",num_str real_mult_commute), - (* z * w = w * z *) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) - Thm ("real_mult_assoc",num_str real_mult_assoc), - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) - Thm ("real_add_commute",num_str real_add_commute), - (*z + w = w + z*) - Thm ("real_add_left_commute",num_str real_add_left_commute), - (*x + (y + z) = y + (x + z)*) - Thm ("real_add_assoc",num_str real_add_assoc) - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) - ], scr = EmptyScr}:rls); - -val collect_bdv = prep_rls( - Rls{id = "collect_bdv", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("bdv_collect_1",num_str bdv_collect_1), - Thm ("bdv_collect_2",num_str bdv_collect_2), - Thm ("bdv_collect_3",num_str bdv_collect_3), - - Thm ("bdv_collect_assoc1_1",num_str bdv_collect_assoc1_1), - Thm ("bdv_collect_assoc1_2",num_str bdv_collect_assoc1_2), - Thm ("bdv_collect_assoc1_3",num_str bdv_collect_assoc1_3), - - Thm ("bdv_collect_assoc2_1",num_str bdv_collect_assoc2_1), - Thm ("bdv_collect_assoc2_2",num_str bdv_collect_assoc2_2), - Thm ("bdv_collect_assoc2_3",num_str bdv_collect_assoc2_3), - - - Thm ("bdv_n_collect_1",num_str bdv_n_collect_1), - Thm ("bdv_n_collect_2",num_str bdv_n_collect_2), - Thm ("bdv_n_collect_3",num_str bdv_n_collect_3), - - Thm ("bdv_n_collect_assoc1_1",num_str bdv_n_collect_assoc1_1), - Thm ("bdv_n_collect_assoc1_2",num_str bdv_n_collect_assoc1_2), - Thm ("bdv_n_collect_assoc1_3",num_str bdv_n_collect_assoc1_3), - - Thm ("bdv_n_collect_assoc2_1",num_str bdv_n_collect_assoc2_1), - Thm ("bdv_n_collect_assoc2_2",num_str bdv_n_collect_assoc2_2), - Thm ("bdv_n_collect_assoc2_3",num_str bdv_n_collect_assoc2_3) - ], scr = EmptyScr}:rls); - -(*.transforms an arbitrary term without roots to a polynomial [4] - according to knowledge/Poly.sml.*) -val make_polynomial_in = prep_rls( - Seq {id = "make_polynomial_in", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [], (*asm_thm = [],*) - rules = [Rls_ expand_poly, - Rls_ order_add_mult_in, - Rls_ simplify_power, - Rls_ collect_numerals, - Rls_ reduce_012, - Thm ("realpow_oneI",num_str realpow_oneI), - Rls_ discard_parentheses, - Rls_ collect_bdv - ], - scr = EmptyScr - }:rls); - -val separate_bdvs = - append_rls "separate_bdvs" - collect_bdv - [Thm ("separate_bdv", num_str separate_bdv), - (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) - Thm ("separate_bdv_n", num_str separate_bdv_n), - Thm ("separate_1_bdv", num_str separate_1_bdv), - (*"?bdv / ?b = (1 / ?b) * ?bdv"*) - Thm ("separate_1_bdv_n", num_str separate_1_bdv_n), - (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) - Thm ("real_add_divide_distrib", - num_str real_add_divide_distrib) - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z" - WN051031 DOES NOT BELONG TO HERE*) - ]; -val make_ratpoly_in = prep_rls( - Seq {id = "make_ratpoly_in", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [], (*asm_thm = [],*) - rules = [Rls_ norm_Rational, - Rls_ order_add_mult_in, - Rls_ discard_parentheses, - Rls_ separate_bdvs, - (* Rls_ rearrange_assoc, WN060916 why does cancel_p not work?*) - Rls_ cancel_p - (*Calc ("HOL.divide" ,eval_cancel "#divide_") too weak!*) - ], - scr = EmptyScr}:rls); - - -ruleset' := overwritelthy thy (!ruleset', - [("order_add_mult_in", order_add_mult_in), - ("collect_bdv", collect_bdv), - ("make_polynomial_in", make_polynomial_in), - ("make_ratpoly_in", make_ratpoly_in), - ("separate_bdvs", separate_bdvs) - ]); - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/PolyEq.thy --- a/src/Tools/isac/IsacKnowledge/PolyEq.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,407 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* theory collecting all knowledge - (predicates 'is_rootEq_in', 'is_sqrt_in', 'is_ratEq_in') - for PolynomialEquations. - alternative dependencies see Isac.thy - created by: rlang - date: 02.07 - changed by: rlang - last change by: rlang - date: 03.06.03 -*) - -(* remove_thy"PolyEq"; - use_thy"IsacKnowledge/Isac"; - use_thy"IsacKnowledge/PolyEq"; - - remove_thy"PolyEq"; - use_thy"Isac"; - - use"ROOT.ML"; - cd"knowledge"; - *) - -PolyEq = LinEq + RootRatEq + -(*-------------------- consts ------------------------------------------------*) -consts - -(*---------scripts--------------------------*) - Complete'_square - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Complete'_square (_ _ =))// \ - \ (_))" 9) - (*----- poly ----- *) - Normalize'_poly - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Normalize'_poly (_ _=))// \ - \ (_))" 9) - Solve'_d0'_polyeq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d0'_polyeq'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d1'_polyeq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d1'_polyeq'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d2'_polyeq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d2'_polyeq'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d2'_polyeq'_sqonly'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d2'_polyeq'_sqonly'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d2'_polyeq'_bdvonly'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d2'_polyeq'_bdvonly'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d2'_polyeq'_pq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d2'_polyeq'_pq'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d2'_polyeq'_abc'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d2'_polyeq'_abc'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d3'_polyeq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d3'_polyeq'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_d4'_polyeq'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_d4'_polyeq'_equation (_ _ =))// \ - \ (_))" 9) - Biquadrat'_poly - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Biquadrat'_poly (_ _=))// \ - \ (_))" 9) - -(*-------------------- rules -------------------------------------------------*) -rules - - cancel_leading_coeff1 "Not (c =!= 0) ==> (a + b*bdv + c*bdv^^^2 = 0) = \ - \ (a/c + b/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff2 "Not (c =!= 0) ==> (a - b*bdv + c*bdv^^^2 = 0) = \ - \ (a/c - b/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff3 "Not (c =!= 0) ==> (a + b*bdv - c*bdv^^^2 = 0) = \ - \ (a/c + b/c*bdv - bdv^^^2 = 0)" - - cancel_leading_coeff4 "Not (c =!= 0) ==> (a + bdv + c*bdv^^^2 = 0) = \ - \ (a/c + 1/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff5 "Not (c =!= 0) ==> (a - bdv + c*bdv^^^2 = 0) = \ - \ (a/c - 1/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff6 "Not (c =!= 0) ==> (a + bdv - c*bdv^^^2 = 0) = \ - \ (a/c + 1/c*bdv - bdv^^^2 = 0)" - - cancel_leading_coeff7 "Not (c =!= 0) ==> ( b*bdv + c*bdv^^^2 = 0) = \ - \ ( b/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff8 "Not (c =!= 0) ==> ( b*bdv - c*bdv^^^2 = 0) = \ - \ ( b/c*bdv - bdv^^^2 = 0)" - - cancel_leading_coeff9 "Not (c =!= 0) ==> ( bdv + c*bdv^^^2 = 0) = \ - \ ( 1/c*bdv + bdv^^^2 = 0)" - cancel_leading_coeff10"Not (c =!= 0) ==> ( bdv - c*bdv^^^2 = 0) = \ - \ ( 1/c*bdv - bdv^^^2 = 0)" - - cancel_leading_coeff11"Not (c =!= 0) ==> (a + b*bdv^^^2 = 0) = \ - \ (a/b + bdv^^^2 = 0)" - cancel_leading_coeff12"Not (c =!= 0) ==> (a - b*bdv^^^2 = 0) = \ - \ (a/b - bdv^^^2 = 0)" - cancel_leading_coeff13"Not (c =!= 0) ==> ( b*bdv^^^2 = 0) = \ - \ ( bdv^^^2 = 0/b)" - - complete_square1 "(q + p*bdv + bdv^^^2 = 0) = \ - \(q + (p/2 + bdv)^^^2 = (p/2)^^^2)" - complete_square2 "( p*bdv + bdv^^^2 = 0) = \ - \( (p/2 + bdv)^^^2 = (p/2)^^^2)" - complete_square3 "( bdv + bdv^^^2 = 0) = \ - \( (1/2 + bdv)^^^2 = (1/2)^^^2)" - - complete_square4 "(q - p*bdv + bdv^^^2 = 0) = \ - \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)" - complete_square5 "(q + p*bdv - bdv^^^2 = 0) = \ - \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)" - - square_explicit1 "(a + b^^^2 = c) = ( b^^^2 = c - a)" - square_explicit2 "(a - b^^^2 = c) = (-(b^^^2) = c - a)" - - bdv_explicit1 "(a + bdv = b) = (bdv = - a + b)" - bdv_explicit2 "(a - bdv = b) = ((-1)*bdv = - a + b)" - bdv_explicit3 "((-1)*bdv = b) = (bdv = (-1)*b)" - - plus_leq "(0 <= a + b) = ((-1)*b <= a)"(*Isa?*) - minus_leq "(0 <= a - b) = ( b <= a)"(*Isa?*) - -(*-- normalize --*) - (*WN0509 compare LinEq.all_left "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"*) - all_left - "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)" - makex1_x - "a^^^1 = a" - real_assoc_1 - "a+(b+c) = a+b+c" - real_assoc_2 - "a*(b*c) = a*b*c" - -(* ---- degree 0 ----*) - d0_true - "(0=0) = True" - d0_false - "[|Not(bdv occurs_in a);Not(a=0)|] ==> (a=0) = False" -(* ---- degree 1 ----*) - d1_isolate_add1 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv = 0) = (b*bdv = (-1)*a)" - d1_isolate_add2 - "[|Not(bdv occurs_in a)|] ==> (a + bdv = 0) = ( bdv = (-1)*a)" - d1_isolate_div - "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv = c) = (bdv = c/b)" -(* ---- degree 2 ----*) - d2_isolate_add1 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^2=0) = (b*bdv^^^2= (-1)*a)" - d2_isolate_add2 - "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^2=0) = ( bdv^^^2= (-1)*a)" - d2_isolate_div - "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv^^^2=c) = (bdv^^^2=c/b)" - d2_prescind1 - "(a*bdv + b*bdv^^^2 = 0) = (bdv*(a +b*bdv)=0)" - d2_prescind2 - "(a*bdv + bdv^^^2 = 0) = (bdv*(a + bdv)=0)" - d2_prescind3 - "( bdv + b*bdv^^^2 = 0) = (bdv*(1+b*bdv)=0)" - d2_prescind4 - "( bdv + bdv^^^2 = 0) = (bdv*(1+ bdv)=0)" - (* eliminate degree 2 *) - (* thm for neg arguments in sqroot have postfix _neg *) - d2_sqrt_equation1 - "[|(0<=c);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = ((bdv=sqrt c) | (bdv=(-1)*sqrt c ))" - d2_sqrt_equation1_neg - "[|(c<0);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = False" - d2_sqrt_equation2 - "(bdv^^^2=0) = (bdv=0)" - d2_sqrt_equation3 - "(b*bdv^^^2=0) = (bdv=0)" - d2_reduce_equation1 - "(bdv*(a +b*bdv)=0) = ((bdv=0)|(a+b*bdv=0))" - d2_reduce_equation2 - "(bdv*(a + bdv)=0) = ((bdv=0)|(a+ bdv=0))" - d2_pqformula1 - "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+ bdv^^^2=0) = - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2) - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))" - d2_pqformula1_neg - "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+ bdv^^^2=0) = False" - d2_pqformula2 - "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+1*bdv^^^2=0) = - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2) - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))" - d2_pqformula2_neg - "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+1*bdv^^^2=0) = False" - d2_pqformula3 - "[|0<=1 - 4*q|] ==> (q+ bdv+ bdv^^^2=0) = - ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2) - | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))" - d2_pqformula3_neg - "[|1 - 4*q<0|] ==> (q+ bdv+ bdv^^^2=0) = False" - d2_pqformula4 - "[|0<=1 - 4*q|] ==> (q+ bdv+1*bdv^^^2=0) = - ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2) - | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))" - d2_pqformula4_neg - "[|1 - 4*q<0|] ==> (q+ bdv+1*bdv^^^2=0) = False" - d2_pqformula5 - "[|0<=p^^^2 - 0|] ==> ( p*bdv+ bdv^^^2=0) = - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2) - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))" - (* d2_pqformula5_neg not need p^2 never less zero in R *) - d2_pqformula6 - "[|0<=p^^^2 - 0|] ==> ( p*bdv+1*bdv^^^2=0) = - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2) - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))" - (* d2_pqformula6_neg not need p^2 never less zero in R *) - d2_pqformula7 - "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) = - ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2) - | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))" - (* d2_pqformula7_neg not need, because 1<0 ==> False*) - d2_pqformula8 - "[|0<=1 - 0|] ==> ( bdv+1*bdv^^^2=0) = - ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2) - | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))" - (* d2_pqformula8_neg not need, because 1<0 ==> False*) - d2_pqformula9 - "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ 1*bdv^^^2=0) = - ((bdv= 0 + sqrt(0 - 4*q)/2) - | (bdv= 0 - sqrt(0 - 4*q)/2))" - d2_pqformula9_neg - "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ 1*bdv^^^2=0) = False" - d2_pqformula10 - "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ bdv^^^2=0) = - ((bdv= 0 + sqrt(0 - 4*q)/2) - | (bdv= 0 - sqrt(0 - 4*q)/2))" - d2_pqformula10_neg - "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ bdv^^^2=0) = False" - d2_abcformula1 - "[|0<=b^^^2 - 4*a*c|] ==> (c + b*bdv+a*bdv^^^2=0) = - ((bdv=( -b + sqrt(b^^^2 - 4*a*c))/(2*a)) - | (bdv=( -b - sqrt(b^^^2 - 4*a*c))/(2*a)))" - d2_abcformula1_neg - "[|b^^^2 - 4*a*c<0|] ==> (c + b*bdv+a*bdv^^^2=0) = False" - d2_abcformula2 - "[|0<=1 - 4*a*c|] ==> (c+ bdv+a*bdv^^^2=0) = - ((bdv=( -1 + sqrt(1 - 4*a*c))/(2*a)) - | (bdv=( -1 - sqrt(1 - 4*a*c))/(2*a)))" - d2_abcformula2_neg - "[|1 - 4*a*c<0|] ==> (c+ bdv+a*bdv^^^2=0) = False" - d2_abcformula3 - "[|0<=b^^^2 - 4*1*c|] ==> (c + b*bdv+ bdv^^^2=0) = - ((bdv=( -b + sqrt(b^^^2 - 4*1*c))/(2*1)) - | (bdv=( -b - sqrt(b^^^2 - 4*1*c))/(2*1)))" - d2_abcformula3_neg - "[|b^^^2 - 4*1*c<0|] ==> (c + b*bdv+ bdv^^^2=0) = False" - d2_abcformula4 - "[|0<=1 - 4*1*c|] ==> (c + bdv+ bdv^^^2=0) = - ((bdv=( -1 + sqrt(1 - 4*1*c))/(2*1)) - | (bdv=( -1 - sqrt(1 - 4*1*c))/(2*1)))" - d2_abcformula4_neg - "[|1 - 4*1*c<0|] ==> (c + bdv+ bdv^^^2=0) = False" - d2_abcformula5 - "[|Not(bdv occurs_in c); 0<=0 - 4*a*c|] ==> (c + a*bdv^^^2=0) = - ((bdv=( 0 + sqrt(0 - 4*a*c))/(2*a)) - | (bdv=( 0 - sqrt(0 - 4*a*c))/(2*a)))" - d2_abcformula5_neg - "[|Not(bdv occurs_in c); 0 - 4*a*c<0|] ==> (c + a*bdv^^^2=0) = False" - d2_abcformula6 - "[|Not(bdv occurs_in c); 0<=0 - 4*1*c|] ==> (c+ bdv^^^2=0) = - ((bdv=( 0 + sqrt(0 - 4*1*c))/(2*1)) - | (bdv=( 0 - sqrt(0 - 4*1*c))/(2*1)))" - d2_abcformula6_neg - "[|Not(bdv occurs_in c); 0 - 4*1*c<0|] ==> (c+ bdv^^^2=0) = False" - d2_abcformula7 - "[|0<=b^^^2 - 0|] ==> ( b*bdv+a*bdv^^^2=0) = - ((bdv=( -b + sqrt(b^^^2 - 0))/(2*a)) - | (bdv=( -b - sqrt(b^^^2 - 0))/(2*a)))" - (* d2_abcformula7_neg not need b^2 never less zero in R *) - d2_abcformula8 - "[|0<=b^^^2 - 0|] ==> ( b*bdv+ bdv^^^2=0) = - ((bdv=( -b + sqrt(b^^^2 - 0))/(2*1)) - | (bdv=( -b - sqrt(b^^^2 - 0))/(2*1)))" - (* d2_abcformula8_neg not need b^2 never less zero in R *) - d2_abcformula9 - "[|0<=1 - 0|] ==> ( bdv+a*bdv^^^2=0) = - ((bdv=( -1 + sqrt(1 - 0))/(2*a)) - | (bdv=( -1 - sqrt(1 - 0))/(2*a)))" - (* d2_abcformula9_neg not need, because 1<0 ==> False*) - d2_abcformula10 - "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) = - ((bdv=( -1 + sqrt(1 - 0))/(2*1)) - | (bdv=( -1 - sqrt(1 - 0))/(2*1)))" - (* d2_abcformula10_neg not need, because 1<0 ==> False*) - -(* ---- degree 3 ----*) - d3_reduce_equation1 - "(a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0))" - d3_reduce_equation2 - "( bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0))" - d3_reduce_equation3 - "(a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0))" - d3_reduce_equation4 - "( bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0))" - d3_reduce_equation5 - "(a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0))" - d3_reduce_equation6 - "( bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0))" - d3_reduce_equation7 - "(a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))" - d3_reduce_equation8 - "( bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))" - d3_reduce_equation9 - "(a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0))" - d3_reduce_equation10 - "( bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0))" - d3_reduce_equation11 - "(a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0))" - d3_reduce_equation12 - "( bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0))" - d3_reduce_equation13 - "( b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0))" - d3_reduce_equation14 - "( bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0))" - d3_reduce_equation15 - "( b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0))" - d3_reduce_equation16 - "( bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0))" - d3_isolate_add1 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (b*bdv^^^3= (-1)*a)" - d3_isolate_add2 - "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = ( bdv^^^3= (-1)*a)" - d3_isolate_div - "[|Not(b=0);Not(bdv occurs_in a)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b)" - d3_root_equation2 - "(bdv^^^3=0) = (bdv=0)" - d3_root_equation1 - "(bdv^^^3=c) = (bdv = nroot 3 c)" - -(* ---- degree 4 ----*) - (* RL03.FIXME es wir nicht getestet ob u>0 *) - d4_sub_u1 - "(c+b*bdv^^^2+a*bdv^^^4=0) = - ((a*u^^^2+b*u+c=0) & (bdv^^^2=u))" - -(* ---- 7.3.02 von Termorder ---- *) - - bdv_collect_1 "l * bdv + m * bdv = (l + m) * bdv" - bdv_collect_2 "bdv + m * bdv = (1 + m) * bdv" - bdv_collect_3 "l * bdv + bdv = (l + 1) * bdv" - -(* bdv_collect_assoc0_1 "l * bdv + m * bdv + k = (l + m) * bdv + k" - bdv_collect_assoc0_2 "bdv + m * bdv + k = (1 + m) * bdv + k" - bdv_collect_assoc0_3 "l * bdv + bdv + k = (l + 1) * bdv + k" -*) - bdv_collect_assoc1_1 "l * bdv + (m * bdv + k) = (l + m) * bdv + k" - bdv_collect_assoc1_2 "bdv + (m * bdv + k) = (1 + m) * bdv + k" - bdv_collect_assoc1_3 "l * bdv + (bdv + k) = (l + 1) * bdv + k" - - bdv_collect_assoc2_1 "k + l * bdv + m * bdv = k + (l + m) * bdv" - bdv_collect_assoc2_2 "k + bdv + m * bdv = k + (1 + m) * bdv" - bdv_collect_assoc2_3 "k + l * bdv + bdv = k + (l + 1) * bdv" - - - bdv_n_collect_1 "l * bdv^^^n + m * bdv^^^n = (l + m) * bdv^^^n" - bdv_n_collect_2 " bdv^^^n + m * bdv^^^n = (1 + m) * bdv^^^n" - bdv_n_collect_3 "l * bdv^^^n + bdv^^^n = (l + 1) * bdv^^^n" (*order!*) - - bdv_n_collect_assoc1_1 "l * bdv^^^n + (m * bdv^^^n + k) = (l + m) * bdv^^^n + k" - bdv_n_collect_assoc1_2 "bdv^^^n + (m * bdv^^^n + k) = (1 + m) * bdv^^^n + k" - bdv_n_collect_assoc1_3 "l * bdv^^^n + (bdv^^^n + k) = (l + 1) * bdv^^^n + k" - - bdv_n_collect_assoc2_1 "k + l * bdv^^^n + m * bdv^^^n = k + (l + m) * bdv^^^n" - bdv_n_collect_assoc2_2 "k + bdv^^^n + m * bdv^^^n = k + (1 + m) * bdv^^^n" - bdv_n_collect_assoc2_3 "k + l * bdv^^^n + bdv^^^n = k + (l + 1) * bdv^^^n" - -(*WN.14.3.03*) - real_minus_div "- (a / b) = (-1 * a) / b" - - separate_bdv "(a * bdv) / b = (a / b) * bdv" - separate_bdv_n "(a * bdv ^^^ n) / b = (a / b) * bdv ^^^ n" - separate_1_bdv "bdv / b = (1 / b) * bdv" - separate_1_bdv_n "bdv ^^^ n / b = (1 / b) * bdv ^^^ n" - -end - - - - - - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/PolyMinus.ML --- a/src/Tools/isac/IsacKnowledge/PolyMinus.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,521 +0,0 @@ -(* questionable attempts to perserve binary minus as wanted by teachers - WN071207 - (c) due to copyright terms -remove_thy"PolyMinus"; -use_thy"IsacKnowledge/PolyMinus"; - -use_thy"IsacKnowledge/Isac"; -use"IsacKnowledge/PolyMinus.ML"; -*) - -(** interface isabelle -- isac **) -theory' := overwritel (!theory', [("PolyMinus.thy",PolyMinus.thy)]); - -(** eval functions **) - -(*. get the identifier from specific monomials; see fun ist_monom .*) -(*HACK.WN080107*) -fun increase str = - let val s::ss = explode str - in implode ((chr (ord s + 1))::ss) end; -fun identifier (Free (id,_)) = id (* 2, a *) - | identifier (Const ("op *", _) $ Free (num, _) $ Free (id, _)) = - id (* 2*a, a*b *) - | identifier (Const ("op *", _) $ (* 3*a*b *) - (Const ("op *", _) $ - Free (num, _) $ Free _) $ Free (id, _)) = - if is_numeral num then id - else "|||||||||||||" - | identifier (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) = - if is_numeral base then "|||||||||||||" (* a^2 *) - else (*increase*) base - | identifier (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *) - (Const ("Atools.pow", _) $ - Free (base, _) $ Free (exp, _))) = - if is_numeral num andalso not (is_numeral base) then (*increase*) base - else "|||||||||||||" - | identifier _ = "|||||||||||||"(*the "largest" string*); - -(*("kleiner", ("PolyMinus.kleiner", eval_kleiner ""))*) -(* order "by alphabet" w.r.t. var: num < (var | num*var) > (var*var | ..) *) -fun eval_kleiner _ _ (p as (Const ("PolyMinus.kleiner",_) $ a $ b)) _ = - if is_num b then - if is_num a then (*123 kleiner 32 = True !!!*) - if int_of_Free a < int_of_Free b then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - else (* -1 * -2 kleiner 0 *) - SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - else - if identifier a < identifier b then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_kleiner _ _ _ _ = NONE; - -fun ist_monom (Free (id,_)) = true - | ist_monom (Const ("op *", _) $ Free (num, _) $ Free (id, _)) = - if is_numeral num then true else false - | ist_monom _ = false; -(*. this function only accepts the most simple monoms vvvvvvvvvv .*) -fun ist_monom (Free (id,_)) = true (* 2, a *) - | ist_monom (Const ("op *", _) $ Free _ $ Free (id, _)) = (* 2*a, a*b *) - if is_numeral id then false else true - | ist_monom (Const ("op *", _) $ (* 3*a*b *) - (Const ("op *", _) $ - Free (num, _) $ Free _) $ Free (id, _)) = - if is_numeral num andalso not (is_numeral id) then true else false - | ist_monom (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) = - true (* a^2 *) - | ist_monom (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *) - (Const ("Atools.pow", _) $ - Free (base, _) $ Free (exp, _))) = - if is_numeral num then true else false - | ist_monom _ = false; - -(* is this a univariate monomial ? *) -(*("ist_monom", ("PolyMinus.ist'_monom", eval_ist_monom ""))*) -fun eval_ist_monom _ _ (p as (Const ("PolyMinus.ist'_monom",_) $ a)) _ = - if ist_monom a then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = False", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_ist_monom _ _ _ _ = NONE; - - -(** rewrite order **) - -(** rulesets **) - -val erls_ordne_alphabetisch = - append_rls "erls_ordne_alphabetisch" e_rls - [Calc ("PolyMinus.kleiner", eval_kleiner ""), - Calc ("PolyMinus.ist'_monom", eval_ist_monom "") - ]; - -val ordne_alphabetisch = - Rls{id = "ordne_alphabetisch", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], - erls = erls_ordne_alphabetisch, - rules = [Thm ("tausche_plus",num_str tausche_plus), - (*"b kleiner a ==> (b + a) = (a + b)"*) - Thm ("tausche_minus",num_str tausche_minus), - (*"b kleiner a ==> (b - a) = (-a + b)"*) - Thm ("tausche_vor_plus",num_str tausche_vor_plus), - (*"[| b ist_monom; a kleiner b |] ==> (- b + a) = (a - b)"*) - Thm ("tausche_vor_minus",num_str tausche_vor_minus), - (*"[| b ist_monom; a kleiner b |] ==> (- b - a) = (-a - b)"*) - Thm ("tausche_plus_plus",num_str tausche_plus_plus), - (*"c kleiner b ==> (a + c + b) = (a + b + c)"*) - Thm ("tausche_plus_minus",num_str tausche_plus_minus), - (*"c kleiner b ==> (a + c - b) = (a - b + c)"*) - Thm ("tausche_minus_plus",num_str tausche_minus_plus), - (*"c kleiner b ==> (a - c + b) = (a + b - c)"*) - Thm ("tausche_minus_minus",num_str tausche_minus_minus) - (*"c kleiner b ==> (a - c - b) = (a - b - c)"*) - ], scr = EmptyScr}:rls; - -val fasse_zusammen = - Rls{id = "fasse_zusammen", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), - erls = append_rls "erls_fasse_zusammen" e_rls - [Calc ("Atools.is'_const",eval_const "#is_const_")], - srls = Erls, calc = [], - rules = - [Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r), - (*"[| l is_const; m..|] ==> (k + m * n) + l * n = k + (l + m)*n"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r), - (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*) - - - Thm ("subtrahiere",num_str subtrahiere), - (*"[| l is_const; m is_const |] ==> m * v - l * v = (m - l) * v"*) - Thm ("subtrahiere_von_1",num_str subtrahiere_von_1), - (*"[| l is_const |] ==> v - l * v = (1 - l) * v"*) - Thm ("subtrahiere_1",num_str subtrahiere_1), - (*"[| l is_const; m is_const |] ==> m * v - v = (m - 1) * v"*) - - Thm ("subtrahiere_x_plus_minus",num_str subtrahiere_x_plus_minus), - (*"[| l is_const; m..|] ==> (k + m * n) - l * n = k + ( m - l) * n"*) - Thm ("subtrahiere_x_plus1_minus",num_str subtrahiere_x_plus1_minus), - (*"[| l is_const |] ==> (x + v) - l * v = x + (1 - l) * v"*) - Thm ("subtrahiere_x_plus_minus1",num_str subtrahiere_x_plus_minus1), - (*"[| m is_const |] ==> (x + m * v) - v = x + (m - 1) * v"*) - - Thm ("subtrahiere_x_minus_plus",num_str subtrahiere_x_minus_plus), - (*"[| l is_const; m..|] ==> (k - m * n) + l * n = k + (-m + l) * n"*) - Thm ("subtrahiere_x_minus1_plus",num_str subtrahiere_x_minus1_plus), - (*"[| l is_const |] ==> (x - v) + l * v = x + (-1 + l) * v"*) - Thm ("subtrahiere_x_minus_plus1",num_str subtrahiere_x_minus_plus1), - (*"[| m is_const |] ==> (x - m * v) + v = x + (-m + 1) * v"*) - - Thm ("subtrahiere_x_minus_minus",num_str subtrahiere_x_minus_minus), - (*"[| l is_const; m..|] ==> (k - m * n) - l * n = k + (-m - l) * n"*) - Thm ("subtrahiere_x_minus1_minus",num_str subtrahiere_x_minus1_minus), - (*"[| l is_const |] ==> (x - v) - l * v = x + (-1 - l) * v"*) - Thm ("subtrahiere_x_minus_minus1",num_str subtrahiere_x_minus_minus1), - (*"[| m is_const |] ==> (x - m * v) - v = x + (-m - 1) * v"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#subtr_"), - - (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen - (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *) - Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r), - (*"(k + z1) + z1 = k + 2 * z1"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - - Thm ("addiere_vor_minus",num_str addiere_vor_minus), - (*"[| l is_const; m is_const |] ==> -(l * v) + m * v = (-l + m) *v"*) - Thm ("addiere_eins_vor_minus",num_str addiere_eins_vor_minus), - (*"[| m is_const |] ==> - v + m * v = (-1 + m) * v"*) - Thm ("subtrahiere_vor_minus",num_str subtrahiere_vor_minus), - (*"[| l is_const; m is_const |] ==> -(l * v) - m * v = (-l - m) *v"*) - Thm ("subtrahiere_eins_vor_minus",num_str subtrahiere_eins_vor_minus) - (*"[| m is_const |] ==> - v - m * v = (-1 - m) * v"*) - - ], scr = EmptyScr}:rls; - -val verschoenere = - Rls{id = "verschoenere", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], - erls = append_rls "erls_verschoenere" e_rls - [Calc ("PolyMinus.kleiner", eval_kleiner "")], - rules = [Thm ("vorzeichen_minus_weg1",num_str vorzeichen_minus_weg1), - (*"l kleiner 0 ==> a + l * b = a - -l * b"*) - Thm ("vorzeichen_minus_weg2",num_str vorzeichen_minus_weg2), - (*"l kleiner 0 ==> a - l * b = a + -l * b"*) - Thm ("vorzeichen_minus_weg3",num_str vorzeichen_minus_weg3), - (*"l kleiner 0 ==> k + a - l * b = k + a + -l * b"*) - Thm ("vorzeichen_minus_weg4",num_str vorzeichen_minus_weg4), - (*"l kleiner 0 ==> k - a - l * b = k - a + -l * b"*) - - Calc ("op *", eval_binop "#mult_"), - - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - Thm ("null_minus",num_str null_minus), - (*"0 - a = -a"*) - Thm ("vor_minus_mal",num_str vor_minus_mal) - (*"- a * b = (-a) * b"*) - - (*Thm ("",num_str ),*) - (**) - ], scr = EmptyScr}:rls (*end verschoenere*); - -val klammern_aufloesen = - Rls{id = "klammern_aufloesen", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls, - rules = [Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym)), - (*"a + (b + c) = (a + b) + c"*) - Thm ("klammer_plus_minus",num_str klammer_plus_minus), - (*"a + (b - c) = (a + b) - c"*) - Thm ("klammer_minus_plus",num_str klammer_minus_plus), - (*"a - (b + c) = (a - b) - c"*) - Thm ("klammer_minus_minus",num_str klammer_minus_minus) - (*"a - (b - c) = (a - b) + c"*) - ], scr = EmptyScr}:rls; - -val klammern_ausmultiplizieren = - Rls{id = "klammern_ausmultiplizieren", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls, - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - - Thm ("klammer_mult_minus",num_str klammer_mult_minus), - (*"a * (b - c) = a * b - a * c"*) - Thm ("klammer_minus_mult",num_str klammer_minus_mult) - (*"(b - c) * a = b * a - c * a"*) - - (*Thm ("",num_str ), - (*""*)*) - ], scr = EmptyScr}:rls; - -val ordne_monome = - Rls{id = "ordne_monome", preconds = [], - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], - erls = append_rls "erls_ordne_monome" e_rls - [Calc ("PolyMinus.kleiner", eval_kleiner ""), - Calc ("Atools.is'_atom", eval_is_atom "") - ], - rules = [Thm ("tausche_mal",num_str tausche_mal), - (*"[| b is_atom; a kleiner b |] ==> (b * a) = (a * b)"*) - Thm ("tausche_vor_mal",num_str tausche_vor_mal), - (*"[| b is_atom; a kleiner b |] ==> (-b * a) = (-a * b)"*) - Thm ("tausche_mal_mal",num_str tausche_mal_mal), - (*"[| c is_atom; b kleiner c |] ==> (a * c * b) = (a * b *c)"*) - Thm ("x_quadrat",num_str x_quadrat) - (*"(x * a) * a = x * a ^^^ 2"*) - - (*Thm ("",num_str ), - (*""*)*) - ], scr = EmptyScr}:rls; - - -val rls_p_33 = - append_rls "rls_p_33" e_rls - [Rls_ ordne_alphabetisch, - Rls_ fasse_zusammen, - Rls_ verschoenere - ]; -val rls_p_34 = - append_rls "rls_p_34" e_rls - [Rls_ klammern_aufloesen, - Rls_ ordne_alphabetisch, - Rls_ fasse_zusammen, - Rls_ verschoenere - ]; -val rechnen = - append_rls "rechnen" e_rls - [Calc ("op *", eval_binop "#mult_"), - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#subtr_") - ]; - -ruleset' := -overwritelthy thy (!ruleset', - [("ordne_alphabetisch", prep_rls ordne_alphabetisch), - ("fasse_zusammen", prep_rls fasse_zusammen), - ("verschoenere", prep_rls verschoenere), - ("ordne_monome", prep_rls ordne_monome), - ("klammern_aufloesen", prep_rls klammern_aufloesen), - ("klammern_ausmultiplizieren", - prep_rls klammern_ausmultiplizieren) - ]); - -(** problems **) - -store_pbt - (prep_pbt PolyMinus.thy "pbl_vereinf_poly" [] e_pblID - (["polynom","vereinfachen"], - [], Erls, NONE, [])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_minus" [] e_pblID - (["plus_minus","polynom","vereinfachen"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp", - "Not (matchsub (?a + (?b + ?c)) t_ | \ - \ matchsub (?a + (?b - ?c)) t_ | \ - \ matchsub (?a - (?b + ?c)) t_ | \ - \ matchsub (?a + (?b - ?c)) t_ )", - "Not (matchsub (?a * (?b + ?c)) t_ | \ - \ matchsub (?a * (?b - ?c)) t_ | \ - \ matchsub ((?b + ?c) * ?a) t_ | \ - \ matchsub ((?b - ?c) * ?a) t_ )"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "prls_pbl_vereinf_poly" e_rls - [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), - Calc ("Tools.matchsub", eval_matchsub ""), - Thm ("or_true",or_true), - (*"(?a | True) = True"*) - Thm ("or_false",or_false), - (*"(?a | False) = ?a"*) - Thm ("not_true",num_str not_true), - (*"(~ True) = False"*) - Thm ("not_false",num_str not_false) - (*"(~ False) = True"*)], - SOME "Vereinfache t_", - [["simplification","for_polynomials","with_minus"]])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer" [] e_pblID - (["klammer","polynom","vereinfachen"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp", - "Not (matchsub (?a * (?b + ?c)) t_ | \ - \ matchsub (?a * (?b - ?c)) t_ | \ - \ matchsub ((?b + ?c) * ?a) t_ | \ - \ matchsub ((?b - ?c) * ?a) t_ )"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "prls_pbl_vereinf_poly_klammer" e_rls [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), - Calc ("Tools.matchsub", eval_matchsub ""), - Thm ("or_true",or_true), - (*"(?a | True) = True"*) - Thm ("or_false",or_false), - (*"(?a | False) = ?a"*) - Thm ("not_true",num_str not_true), - (*"(~ True) = False"*) - Thm ("not_false",num_str not_false) - (*"(~ False) = True"*)], - SOME "Vereinfache t_", - [["simplification","for_polynomials","with_parentheses"]])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer_mal" [] e_pblID - (["binom_klammer","polynom","vereinfachen"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*) - Calc ("Poly.is'_polyexp", eval_is_polyexp "")], - SOME "Vereinfache t_", - [["simplification","for_polynomials","with_parentheses_mult"]])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_probe" [] e_pblID - (["probe"], - [], Erls, NONE, [])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_probe_poly" [] e_pblID - (["polynom","probe"], - [("#Given" ,["Pruefe e_", "mitWert ws_"]), - ("#Where" ,["e_ is_polyexp"]), - ("#Find" ,["Geprueft p_"]) - ], - append_rls "prls_pbl_probe_poly" - e_rls [(*for preds in where_*) - Calc ("Poly.is'_polyexp", eval_is_polyexp "")], - SOME "Probe e_ ws_", - [["probe","fuer_polynom"]])); - -store_pbt - (prep_pbt PolyMinus.thy "pbl_probe_bruch" [] e_pblID - (["bruch","probe"], - [("#Given" ,["Pruefe e_", "mitWert ws_"]), - ("#Where" ,["e_ is_ratpolyexp"]), - ("#Find" ,["Geprueft p_"]) - ], - append_rls "prls_pbl_probe_bruch" - e_rls [(*for preds in where_*) - Calc ("Rational.is'_ratpolyexp", eval_is_ratpolyexp "")], - SOME "Probe e_ ws_", - [["probe","fuer_bruch"]])); - - -(** methods **) - -store_met - (prep_met PolyMinus.thy "met_simp_poly_minus" [] e_metID - (["simplification","for_polynomials","with_minus"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp", - "Not (matchsub (?a + (?b + ?c)) t_ | \ - \ matchsub (?a + (?b - ?c)) t_ | \ - \ matchsub (?a - (?b + ?c)) t_ | \ - \ matchsub (?a + (?b - ?c)) t_ )"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = append_rls "prls_met_simp_poly_minus" e_rls - [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), - Calc ("Tools.matchsub", eval_matchsub ""), - Thm ("and_true",and_true), - (*"(?a & True) = ?a"*) - Thm ("and_false",and_false), - (*"(?a & False) = False"*) - Thm ("not_true",num_str not_true), - (*"(~ True) = False"*) - Thm ("not_false",num_str not_false) - (*"(~ False) = True"*)], - crls = e_rls, nrls = rls_p_33}, -"Script SimplifyScript (t_::real) = \ -\ ((Repeat((Try (Rewrite_Set ordne_alphabetisch False)) @@ \ -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ -\ (Try (Rewrite_Set verschoenere False)))) t_)" - )); - -store_met - (prep_met PolyMinus.thy "met_simp_poly_parenth" [] e_metID - (["simplification","for_polynomials","with_parentheses"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = append_rls "simplification_for_polynomials_prls" e_rls - [(*for preds in where_*) - Calc("Poly.is'_polyexp",eval_is_polyexp"")], - crls = e_rls, nrls = rls_p_34}, -"Script SimplifyScript (t_::real) = \ -\ ((Repeat((Try (Rewrite_Set klammern_aufloesen False)) @@ \ -\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \ -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ -\ (Try (Rewrite_Set verschoenere False)))) t_)" - )); - -store_met - (prep_met PolyMinus.thy "met_simp_poly_parenth_mult" [] e_metID - (["simplification","for_polynomials","with_parentheses_mult"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_polyexp"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = append_rls "simplification_for_polynomials_prls" e_rls - [(*for preds in where_*) - Calc("Poly.is'_polyexp",eval_is_polyexp"")], - crls = e_rls, nrls = rls_p_34}, -"Script SimplifyScript (t_::real) = \ -\ ((Repeat((Try (Rewrite_Set klammern_ausmultiplizieren False)) @@ \ -\ (Try (Rewrite_Set discard_parentheses False)) @@ \ -\ (Try (Rewrite_Set ordne_monome False)) @@ \ -\ (Try (Rewrite_Set klammern_aufloesen False)) @@ \ -\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \ -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ -\ (Try (Rewrite_Set verschoenere False)))) t_)" - )); - -store_met - (prep_met PolyMinus.thy "met_probe" [] e_metID - (["probe"], - [], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = Erls, crls = e_rls, nrls = Erls}, - "empty_script")); - -store_met - (prep_met PolyMinus.thy "met_probe_poly" [] e_metID - (["probe","fuer_polynom"], - [("#Given" ,["Pruefe e_", "mitWert ws_"]), - ("#Where" ,["e_ is_polyexp"]), - ("#Find" ,["Geprueft p_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = append_rls "prls_met_probe_bruch" - e_rls [(*for preds in where_*) - Calc ("Rational.is'_ratpolyexp", - eval_is_ratpolyexp "")], - crls = e_rls, nrls = rechnen}, -"Script ProbeScript (e_::bool) (ws_::bool list) = \ -\ (let e_ = Take e_; \ -\ e_ = Substitute ws_ e_ \ -\ in (Repeat((Try (Repeat (Calculate times))) @@ \ -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate minus))))) e_)" -)); - -store_met - (prep_met PolyMinus.thy "met_probe_bruch" [] e_metID - (["probe","fuer_bruch"], - [("#Given" ,["Pruefe e_", "mitWert ws_"]), - ("#Where" ,["e_ is_ratpolyexp"]), - ("#Find" ,["Geprueft p_"]) - ], - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, - prls = append_rls "prls_met_probe_bruch" - e_rls [(*for preds in where_*) - Calc ("Rational.is'_ratpolyexp", - eval_is_ratpolyexp "")], - crls = e_rls, nrls = Erls}, - "empty_script")); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/PolyMinus.thy --- a/src/Tools/isac/IsacKnowledge/PolyMinus.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -(* attempts to perserve binary minus as wanted by Austrian teachers - WN071207 - (c) due to copyright terms -remove_thy"PolyMinus"; -use_thy_only"IsacKnowledge/PolyMinus"; -use_thy"IsacKnowledge/Isac"; -*) - -PolyMinus = (*Poly// due to "is_ratpolyexp" in...*) Rational + - -consts - - (*predicates for conditions in rewriting*) - kleiner :: "['a, 'a] => bool" ("_ kleiner _") - ist'_monom :: "'a => bool" ("_ ist'_monom") - - (*the CAS-command*) - Probe :: "[bool, bool list] => bool" - (*"Probe (3*a+2*b+a = 4*a+2*b) [a=1,b=2]"*) - - (*descriptions for the pbl and met*) - Pruefe :: bool => una - mitWert :: bool list => tobooll - Geprueft :: bool => una - - (*Script-name*) - ProbeScript :: "[bool, bool list, bool] \ - \=> bool" - ("((Script ProbeScript (_ _ =))// (_))" 9) - -rules - - null_minus "0 - a = -a" - vor_minus_mal "- a * b = (-a) * b" - - (*commute with invariant (a.b).c -association*) - tausche_plus "[| b ist_monom; a kleiner b |] ==> \ - \(b + a) = (a + b)" - tausche_minus "[| b ist_monom; a kleiner b |] ==> \ - \(b - a) = (-a + b)" - tausche_vor_plus "[| b ist_monom; a kleiner b |] ==> \ - \(- b + a) = (a - b)" - tausche_vor_minus "[| b ist_monom; a kleiner b |] ==> \ - \(- b - a) = (-a - b)" - tausche_plus_plus "b kleiner c ==> (a + c + b) = (a + b + c)" - tausche_plus_minus "b kleiner c ==> (a + c - b) = (a - b + c)" - tausche_minus_plus "b kleiner c ==> (a - c + b) = (a + b - c)" - tausche_minus_minus "b kleiner c ==> (a - c - b) = (a - b - c)" - - (*commute with invariant (a.b).c -association*) - tausche_mal "[| b is_atom; a kleiner b |] ==> \ - \(b * a) = (a * b)" - tausche_vor_mal "[| b is_atom; a kleiner b |] ==> \ - \(-b * a) = (-a * b)" - tausche_mal_mal "[| c is_atom; b kleiner c |] ==> \ - \(x * c * b) = (x * b * c)" - x_quadrat "(x * a) * a = x * a ^^^ 2" - - - subtrahiere "[| l is_const; m is_const |] ==> \ - \m * v - l * v = (m - l) * v" - subtrahiere_von_1 "[| l is_const |] ==> \ - \v - l * v = (1 - l) * v" - subtrahiere_1 "[| l is_const; m is_const |] ==> \ - \m * v - v = (m - 1) * v" - - subtrahiere_x_plus_minus "[| l is_const; m is_const |] ==> \ - \(x + m * v) - l * v = x + (m - l) * v" - subtrahiere_x_plus1_minus "[| l is_const |] ==> \ - \(x + v) - l * v = x + (1 - l) * v" - subtrahiere_x_plus_minus1 "[| m is_const |] ==> \ - \(x + m * v) - v = x + (m - 1) * v" - - subtrahiere_x_minus_plus "[| l is_const; m is_const |] ==> \ - \(x - m * v) + l * v = x + (-m + l) * v" - subtrahiere_x_minus1_plus "[| l is_const |] ==> \ - \(x - v) + l * v = x + (-1 + l) * v" - subtrahiere_x_minus_plus1 "[| m is_const |] ==> \ - \(x - m * v) + v = x + (-m + 1) * v" - - subtrahiere_x_minus_minus "[| l is_const; m is_const |] ==> \ - \(x - m * v) - l * v = x + (-m - l) * v" - subtrahiere_x_minus1_minus"[| l is_const |] ==> \ - \(x - v) - l * v = x + (-1 - l) * v" - subtrahiere_x_minus_minus1"[| m is_const |] ==> \ - \(x - m * v) - v = x + (-m - 1) * v" - - - addiere_vor_minus "[| l is_const; m is_const |] ==> \ - \- (l * v) + m * v = (-l + m) * v" - addiere_eins_vor_minus "[| m is_const |] ==> \ - \- v + m * v = (-1 + m) * v" - subtrahiere_vor_minus "[| l is_const; m is_const |] ==> \ - \- (l * v) - m * v = (-l - m) * v" - subtrahiere_eins_vor_minus"[| m is_const |] ==> \ - \- v - m * v = (-1 - m) * v" - - vorzeichen_minus_weg1 "l kleiner 0 ==> a + l * b = a - -1*l * b" - vorzeichen_minus_weg2 "l kleiner 0 ==> a - l * b = a + -1*l * b" - vorzeichen_minus_weg3 "l kleiner 0 ==> k + a - l * b = k + a + -1*l * b" - vorzeichen_minus_weg4 "l kleiner 0 ==> k - a - l * b = k - a + -1*l * b" - - (*klammer_plus_plus = (real_add_assoc RS sym)*) - klammer_plus_minus "a + (b - c) = (a + b) - c" - klammer_minus_plus "a - (b + c) = (a - b) - c" - klammer_minus_minus "a - (b - c) = (a - b) + c" - - klammer_mult_minus "a * (b - c) = a * b - a * c" - klammer_minus_mult "(b - c) * a = b * a - c * a" - - - -end - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RatEq.ML --- a/src/Tools/isac/IsacKnowledge/RatEq.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,203 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* collecting all knowledge for RationalEquations - created by: rlang - date: 02.09 - changed by: rlang - last change by: rlang - date: 02.11.29 -*) - -(* use"IsacKnowledge/RatEq.ML"; - use"RatEq.ML"; - remove_thy"RatEq"; - use_thy"Isac"; - - use"ROOT.ML"; - cd"IsacKnowledge"; - *) -"******* RatEq.ML begin *******"; - -theory' := overwritel (!theory', [("RatEq.thy",RatEq.thy)]); - -(*-------------------------functions-----------------------*) -(* is_rateqation_in becomes true, if a bdv is in the denominator of a fraction*) -fun is_rateqation_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun finddivide (_ $ _ $ _ $ _) v = raise error("is_rateqation_in:") - (* at the moment there is no term like this, but ....*) - | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = coeff_in b v - | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) - orelse (finddivide t2 v) - | finddivide (_ $ t1) v = (finddivide t1 v) - | finddivide _ _ = false; - in - finddivide t v - end; - -fun eval_is_ratequation_in _ _ (p as (Const ("RatEq.is'_ratequation'_in",_) $ t $ v)) _ = - if is_rateqation_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_ratequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - -(*-------------------------rulse-----------------------*) -val RatEq_prls = (*15.10.02:just the following order due to subterm evaluation*) - append_rls "RatEq_prls" e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Tools.lhs" ,eval_lhs ""), - Calc ("Tools.rhs" ,eval_rhs ""), - Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""), - Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false), - Thm ("or_true",num_str or_true), - Thm ("or_false",num_str or_false) - ]; - - -(*rls = merge_rls erls Poly_erls *) -val rateq_erls = - remove_rls "rateq_erls" (*WN: ein Hack*) - (merge_rls "is_ratequation_in" calculate_Rational - (append_rls "is_ratequation_in" - Poly_erls - [(*Calc ("HOL.divide", eval_cancel "#divide_"),*) - Calc ("RatEq.is'_ratequation'_in", - eval_is_ratequation_in "") - - ])) - [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*) - Thm ("or_commute",num_str or_commute) (*WN: ein Hack*) - ]; -ruleset' := overwritelthy thy (!ruleset', - [("rateq_erls",rateq_erls)(*FIXXXME:del with rls.rls'*) - ]); - - -val RatEq_crls = - remove_rls "RatEq_crls" (*WN: ein Hack*) - (merge_rls "is_ratequation_in" calculate_Rational - (append_rls "is_ratequation_in" - Poly_erls - [(*Calc ("HOL.divide", eval_cancel "#divide_"),*) - Calc ("RatEq.is'_ratequation'_in", - eval_is_ratequation_in "") - ])) - [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*) - Thm ("or_commute",num_str or_commute) (*WN: ein Hack*) - ]; - -val RatEq_eliminate = prep_rls( - Rls {id = "RatEq_eliminate", preconds = [], rew_ord = ("termlessI",termlessI), - erls = rateq_erls, srls = Erls, calc = [], - (*asm_thm = [("rat_mult_denominator_both",""),("rat_mult_denominator_left",""), - ("rat_mult_denominator_right","")],*) - rules = [ - Thm("rat_mult_denominator_both",num_str rat_mult_denominator_both), - (* a/b=c/d -> ad=cb *) - Thm("rat_mult_denominator_left",num_str rat_mult_denominator_left), - (* a =c/d -> ad=c *) - Thm("rat_mult_denominator_right",num_str rat_mult_denominator_right) - (* a/b=c -> a=cb *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("RatEq_eliminate",RatEq_eliminate) - ]); - - - - -val RatEq_simplify = prep_rls( - Rls {id = "RatEq_simplify", preconds = [], rew_ord = ("termlessI",termlessI), - erls = rateq_erls, srls = Erls, calc = [], - (*asm_thm = [("rat_double_rat_1",""),("rat_double_rat_2",""), - ("rat_double_rat_3","")],*) - rules = [ - Thm("real_rat_mult_1",num_str real_rat_mult_1), - (*a*(b/c) = (a*b)/c*) - Thm("real_rat_mult_2",num_str real_rat_mult_2), - (*(a/b)*(c/d) = (a*c)/(b*d)*) - Thm("real_rat_mult_3",num_str real_rat_mult_3), - (* (a/b)*c = (a*c)/b*) - Thm("real_rat_pow",num_str real_rat_pow), - (*(a/b)^^^2 = a^^^2/b^^^2*) - Thm("real_diff_minus",num_str real_diff_minus), - (* a - b = a + (-1) * b *) - Thm("rat_double_rat_1",num_str rat_double_rat_1), - (* (a / (c/d) = (a*d) / c) *) - Thm("rat_double_rat_2",num_str rat_double_rat_2), - (* ((a/b) / (c/d) = (a*d) / (b*c)) *) - Thm("rat_double_rat_3",num_str rat_double_rat_3) - (* ((a/b) / c = a / (b*c) ) *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("RatEq_simplify",RatEq_simplify) - ]); - -(*-------------------------Problem-----------------------*) -(* -(get_pbt ["rational","univariate","equation"]); -show_ptyps(); -*) -store_pbt - (prep_pbt RatEq.thy "pbl_equ_univ_rat" [] e_pblID - (["rational","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]), - ("#Find" ,["solutions v_i_"]) - ], - - RatEq_prls, SOME "solve (e_::bool, v_)", - [["RatEq","solve_rat_equation"]])); - - -(*-------------------------methods-----------------------*) -store_met - (prep_met RatEq.thy "met_rateq" [] e_metID - (["RatEq"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=RatEq_crls, nrls=norm_Rational - (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); -store_met - (prep_met RatEq.thy "met_rat_eq" [] e_metID - (["RatEq","solve_rat_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=rateq_erls, - srls=e_rls, - prls=RatEq_prls, - calc=[], - crls=RatEq_crls, nrls=norm_Rational(*, - asm_rls=[], - asm_thm=[("rat_double_rat_1",""),("rat_double_rat_2",""),("rat_double_rat_3",""), - ("rat_mult_denominator_both",""),("rat_mult_denominator_left",""), - ("rat_mult_denominator_right","")]*)}, - "Script Solve_rat_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Repeat(Try (Rewrite_Set RatEq_simplify True))) @@ \ - \ (Repeat(Try (Rewrite_Set norm_Rational False))) @@ \ - \ (Repeat(Try (Rewrite_Set common_nominator_p False))) @@ \ - \ (Repeat(Try (Rewrite_Set RatEq_eliminate True)))) e_;\ - \ (L_::bool list) = (SubProblem (RatEq_,[univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_]) \ - \ in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -calclist':= overwritel (!calclist', - [("is_ratequation_in", ("RatEq.is_ratequation_in", - eval_is_ratequation_in "")) - ]); -"******* RatEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RatEq.thy --- a/src/Tools/isac/IsacKnowledge/RatEq.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* theory collecting all knowledge for RationalEquations - created by: rlang - date: 02.08.12 - changed by: rlang - last change by: rlang - date: 02.11.28 -*) - -(* - RL.020812 - use_thy"knowledge/RatEq"; - use_thy"RatEq"; - use_thy_only"RatEq"; - - remove_thy"RatEq"; - use_thy"Isac"; - - use"ROOT.ML"; - cd"knowledge"; - *) -RatEq = Rational + - -(*-------------------- consts------------------------------------------------*) -consts - - is'_ratequation'_in :: "[bool, real] => bool" ("_ is'_ratequation'_in _") - - (*----------------------scripts-----------------------*) - Solve'_rat'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_rat'_equation (_ _ =))// \ - \ (_))" 9) - -(*-------------------- rules------------------------------------------------*) -rules - (* FIXME also in Poly.thy def. --> FIXED*) - (*real_diff_minus - "a - b = a + (-1) * b"*) - real_rat_mult_1 - "a*(b/c) = (a*b)/c" - real_rat_mult_2 - "(a/b)*(c/d) = (a*c)/(b*d)" - real_rat_mult_3 - "(a/b)*c = (a*c)/b" - real_rat_pow - "(a/b)^^^2 = a^^^2/b^^^2" - - rat_double_rat_1 - "[|Not(c=0); Not(d=0)|] ==> (a / (c/d) = (a*d) / c)" - rat_double_rat_2 - "[|Not(b=0);Not(c=0); Not(d=0)|] ==> ((a/b) / (c/d) = (a*d) / (b*c))" - rat_double_rat_3 - "[|Not(b=0);Not(c=0)|] ==> ((a/b) / c = a / (b*c))" - - - (* equation to same denominator *) - rat_mult_denominator_both - "[|Not(b=0); Not(d=0)|] ==> ((a::real) / b = c / d) = (a*d = c*b)" - rat_mult_denominator_left - "[|Not(d=0)|] ==> ((a::real) = c / d) = (a*d = c)" - rat_mult_denominator_right - "[|Not(b=0)|] ==> ((a::real) / b = c) = (a = c*b)" - - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Rational-WN.sml --- a/src/Tools/isac/IsacKnowledge/Rational-WN.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ -(*Stefan K.*) - -(*protokoll 14.3.02 -------------------------------------------------- -val ct = parse thy "(a + #1)//(#2*a^^^#2 - #2)"; -val t = (term_of o the) ct; -atomt t; -val ct = parse thy "not (#1+a)"; (*HOL.thy ?*) -val t = (term_of o the) ct; -atomt t; -val ct = parse thy "x"; (*momentan ist alles 'real'*) -val t = (term_of o the) ct; -atomty t; -val ct = parse thy "(x::int)"; (* !!! *) -val t = (term_of o the) ct; -atomty t; - -val ct = parse thy "(x::int)*(y::real)"; (*momentan ist alles 'real'*) - -val Const ("RatArith.cancel",_) $ zaehler $ nenner = t; ----------------------------------------------------------------------*) - - -(*diese vvv funktionen kommen nach src/Isa99/term_G.sml -------------*) -fun term2str t = - let fun ato (Const(a,T)) n = - "\n"^indent n^"Const ( "^a^")" - | ato (Free (a,T)) n = - "\n"^indent n^"Free ( "^a^", "^")" - | ato (Var ((a,ix),T)) n = - "\n"^indent n^"Var (("^a^", "^string_of_int ix^"), "^")" - | ato (Bound ix) n = - "\n"^indent n^"Bound "^string_of_int ix - | ato (Abs(a,T,body)) n = - "\n"^indent n^"Abs( "^a^",.."^ato body (n+1) - | ato (f$t') n = ato f n^ato t' (n+1) - in "\n-------------"^ato t 0^"\n" end; -fun free2int (t as Free (s, _)) = (((the o int_of_str) s) - handle _ => raise error ("free2int: "^term2str t)) - | free2int t = raise error ("free2int: "^term2str t); -(*diese ^^^ funktionen kommen nach src/Isa99/term_G.sml -------------*) - - -(* remark on exceptions: 'error' is implemented by Isabelle - as the typical system error *) - - -type poly = int list; - -(* transform a Isabelle-term t into internal polynomial format - preconditions for t: - a-b -> a+(-b) - x^1 -> x - term ordered ascending - parentheses right side (caused by 'ordered rewriting') - variable as power (not as product) *) - -fun mono (Const ("RatArith.pow",_) $ t1 $ t2) v g = - if t1 = v then ((replicate ((free2int t2) - g) 0) @ [1]) : poly - else raise error ("term2poly.1 "^term2str t1) - | mono (t as Const ("op *",_) $ t1 $ - (Const ("RatArith.pow",_) $ t2 $ t3)) v g = - if t2 = v then (replicate ((free2int t3) - g) 0) @ [free2int t1] - else raise error ("term2poly.2 "^term2str t) - | mono t _ _ = raise error ("term2poly.3 "^term2str t); - -fun poly (Const ("op +",_) $ t1 $ t2) v g = - let val l = mono t1 v g - in (l @ (poly t2 v ((length l) + g))) end - | poly t v g = mono t v g; - -fun term2poly (t as Free (s, _)) v = - if t = v then SOME ([0,1] : poly) else (SOME [(the o int_of_str) s] - handle _ => NONE) - | term2poly (Const ("op *",_) $ (Free (s1,_)) $ (t as Free (s2,_))) v = - if t = v then SOME [0, (the o int_of_str) s1] else NONE - | term2poly (Const ("op +",_) $ (Free (s1,_)) $ t) v = - SOME ([(the o int_of_str) s1] @ (poly t v 1)) - | term2poly t v = - SOME (poly t v 0) handle _ => NONE; - -(*tests*) -val v = (term_of o the o (parse thy)) "x::real"; -val t = (term_of o the o (parse thy)) "#-1::real"; -term2poly t v; -val t = (term_of o the o (parse thy)) "x::real"; -term2poly t v; -val t = (term_of o the o (parse thy)) "#1 * x::real"; (*FIXME: drop it*) -term2poly t v; -val t = (term_of o the o (parse thy)) "x^^^#1"; (*FIXME: drop it*) -term2poly t v; -val t = (term_of o the o (parse thy)) "x^^^#3"; -term2poly t v; -val t = (term_of o the o (parse thy)) "#3 * x^^^#3"; -term2poly t v; -val t = (term_of o the o (parse thy)) "#-1 + #3 * x^^^#3"; -term2poly t v; -val t = (term_of o the o (parse thy)) "#-1 + (#3 * x^^^#3 + #5 * x^^^#5)"; -term2poly t v; -val t = (term_of o the o (parse thy)) - "#-1 + (#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7))"; -term2poly t v; -val t = (term_of o the o (parse thy)) - "#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7)"; -term2poly t v; - - -fun is_polynomial_in t v = - case term2poly t v of SOME _ => true | NONE => false; - -(* transform the internal polynomial p into an Isabelle term t - where t meets the preconditions of term2poly -val mk_mono = - fn : typ -> of the coefficients - typ -> of the unknown - typ -> of the monomial and polynomial - typ -> of the exponent of the unknown - int -> the coefficient <> 0 - string -> the unknown - int -> the degree, i.e. the value of the exponent - term -remark: all the typs above are "RealDef.real" due to the typs of * + ^ -which may change in the future -*) -fun mk_mono cT vT pT eT c v g = - case g of - 0 => Free (str_of_int c, cT) (*will cause problems with diff.typs*) - | 1 => if c = 1 then Free (v, vT) - else Const ("op *", [cT, vT]--->pT) $ - Free (str_of_int c, cT) $ Free (v, vT) - | n => if c = 1 then (Const ("RatArith.pow", [vT, eT]--->pT) $ - Free (v, vT) $ Free (str_of_int g, eT)) - else Const ("op *", [cT, vT]--->pT) $ - Free (str_of_int c, cT) $ - (Const ("RatArith.pow", [vT, eT]--->pT) $ - Free (v, vT) $ Free (str_of_int g, eT)); -(*tests*) -val cT = HOLogic.realT; val vT = HOLogic.realT; val pT = HOLogic.realT; -val eT = HOLogic.realT; -val t = mk_mono cT vT pT eT ~5 "x" 5; -(cterm_of thy) t; -val t = mk_mono cT vT pT eT ~1 "x" 0; -(cterm_of thy) t; -val t = mk_mono cT vT pT eT 1 "x" 1; -(cterm_of thy) t; - - -fun mk_sum pT t1 t2 = Const ("op +", [pT, pT]--->pT) $ t1 $ t2; - - -fun poly2term cT vT pT eT ([p]:poly) v = mk_mono cT vT pT eT p v 0 - | poly2term cT vT pT eT (p:poly) v = - let - fun mk_poly cT vT pT eT [] t v g = t - | mk_poly cT vT pT eT [p] t v g = - if p = 0 then t - else mk_sum pT (mk_mono cT vT pT eT p v g) t - | mk_poly cT vT pT eT (p::ps) t v g = - if p = 0 then mk_poly cT vT pT eT ps t v (g-1) - else mk_poly cT vT pT eT ps - (mk_sum pT (mk_mono cT vT pT eT p v g) t) v (g-1) - val (p'::ps') = rev p - val g = (length p) - 1 - in mk_poly cT vT pT eT ps' (mk_mono cT vT pT eT p' v g) v (g-1) end; - -(*tests*) -val t = poly2term cT vT pT eT [~1] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [0,1] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [0,0,0,1] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [0,0,0,3] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [~1,0,0,3] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [~1,0,0,3,0,5] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [~1,0,0,3,0,5,0,7] "x"; -(cterm_of thy) t; -val t = poly2term cT vT pT eT [0,0,0,3,0,5,0,7] "x"; -(cterm_of thy) t; - -"***************************************************************************"; -"* reverse-rewriting 12.8.02 *"; -"***************************************************************************"; -fun rewrite_set_' thy rls put_asm ruless ct = - case ruless of - Rrls _ => raise error "rewrite_set_' not for Rrls" - | Rls _ => - let - datatype switch = Appl | Noap; - fun rew_once ruls asm ct Noap [] = (ct,asm) - | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls - | rew_once ruls asm ct apno (rul::thms) = - case rul of - Thm (thmid, thm) => - (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) - rls put_asm (thm_of_thm rul) ct of - NONE => rew_once ruls asm ct apno thms - | SOME (ct',asm') => - rew_once ruls (asm union asm') ct' Appl (rul::thms)) - | Calc (cc as (op_,_)) => - (case get_calculation_ thy cc ct of - NONE => rew_once ruls asm ct apno thms - | SOME (thmid, thm') => - let - val pairopt = - rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) - rls put_asm thm' ct; - val _ = if pairopt <> NONE then () - else raise error("rewrite_set_, rewrite_ \""^ - (string_of_thmI thm')^"\" \""^ - (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE") - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end); - val ruls = (#rules o rep_rls) ruless; - val (ct',asm') = rew_once ruls [] ct Noap ruls; - in if ct = ct' then NONE else SOME (ct',asm') end; - -(* -fun reverse_rewrite t1 t2 rls = -*) -fun rewrite_set_' thy rls put_asm ruless ct = - case ruless of - Rrls _ => raise error "rewrite_set_' not for Rrls" - | Rls _ => - let - datatype switch = Appl | Noap; - fun rew_once ruls asm ct Noap [] = (ct,asm) - | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls - | rew_once ruls asm ct apno (rul::thms) = - case rul of - Thm (thmid, thm) => - (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) - rls put_asm (thm_of_thm rul) ct of - NONE => rew_once ruls asm ct apno thms - | SOME (ct',asm') => - rew_once ruls (asm union asm') ct' Appl (rul::thms)) - | Calc (cc as (op_,_)) => - (case get_calculation_ thy cc ct of - NONE => rew_once ruls asm ct apno thms - | SOME (thmid, thm') => - let - val pairopt = - rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) - rls put_asm thm' ct; - val _ = if pairopt <> NONE then () - else raise error("rewrite_set_, rewrite_ \""^ - (string_of_thmI thm')^"\" \""^ - (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE") - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end); - val ruls = (#rules o rep_rls) ruless; - val (ct',asm') = rew_once ruls [] ct Noap ruls; - in if ct = ct' then NONE else SOME (ct',asm') end; - - realpow_two; - real_mult_div_cancel1; - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Rational.ML --- a/src/Tools/isac/IsacKnowledge/Rational.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3786 +0,0 @@ -(*.calculate in rationals: gcd, lcm, etc. - (c) Stefan Karnel 2002 - Institute for Mathematics D and Institute for Software Technology, - TU-Graz SS 2002 - Use is subject to license terms. - -use"IsacKnowledge/Rational.ML"; -use"Rational.ML"; - -remove_thy"Rational"; -use_thy"IsacKnowledge/Isac"; -****************************************************************.*) - -(*.***************************************************************** - Remark on notions in the documentation below: - referring to the remark on 'polynomials' in Poly.sml we use - [2] 'polynomial' normalform (Polynom) - [3] 'expanded_term' normalform (Ausmultiplizierter Term), - where normalform [2] is a special case of [3], i.e. [3] implies [2]. - Instead of - 'fraction with numerator and nominator both in normalform [2]' - 'fraction with numerator and nominator both in normalform [3]' - we say: - 'fraction in normalform [2]' - 'fraction in normalform [3]' - or - 'fraction [2]' - 'fraction [3]'. - a 'simple fraction' is a term with '/' as outmost operator and - numerator and nominator in normalform [2] or [3]. -****************************************************************.*) - -signature RATIONALI = -sig - type mv_monom - type mv_poly - val add_fraction_ : theory -> term -> (term * term list) option - val add_fraction_p_ : theory -> term -> (term * term list) option - val calculate_Rational : rls - val calc_rat_erls:rls - val cancel : rls - val cancel_ : theory -> term -> (term * term list) option - val cancel_p : rls - val cancel_p_ : theory -> term -> (term * term list) option - val common_nominator : rls - val common_nominator_ : theory -> term -> (term * term list) option - val common_nominator_p : rls - val common_nominator_p_ : theory -> term -> (term * term list) option - val eval_is_expanded : string -> 'a -> term -> theory -> - (string * term) option - val expanded2polynomial : term -> term option - val factout_ : theory -> term -> (term * term list) option - val factout_p_ : theory -> term -> (term * term list) option - val is_expanded : term -> bool - val is_polynomial : term -> bool - - val mv_gcd : (int * int list) list -> mv_poly -> mv_poly - val mv_lcm : mv_poly -> mv_poly -> mv_poly - - val norm_expanded_rat_ : theory -> term -> (term * term list) option -(*WN0602.2.6.pull into struct !!! - val norm_Rational : rls(*.normalizes an arbitrary rational term without - roots into a simple and canceled fraction - with normalform [2].*) -*) -(*val norm_rational_p : 19.10.02 missing FIXXXXXXXXXXXXME - rls (*.normalizes an rational term [2] without - roots into a simple and canceled fraction - with normalform [2].*) -*) - val norm_rational_ : theory -> term -> (term * term list) option - val polynomial2expanded : term -> term option - val rational_erls : - rls (*.evaluates an arbitrary rational term with numerals.*) - -(*WN0210???SK: fehlen Funktionen, die exportiert werden sollen ? *) -end - -(*.************************************************************************** -survey on the functions -~~~~~~~~~~~~~~~~~~~~~~~ - [2] 'polynomial' :rls | [3]'expanded_term':rls ---------------------:------------------+-------------------:----------------- - factout_p_ : | factout_ : - cancel_p_ : | cancel_ : - :cancel_p | :cancel ---------------------:------------------+-------------------:----------------- - common_nominator_p_: | common_nominator_ : - :common_nominator_p| :common_nominator - add_fraction_p_ : | add_fraction_ : ---------------------:------------------+-------------------:----------------- -???SK :norm_rational_p | :norm_rational - -This survey shows only the principal functions for reuse, and the identifiers -of the rls exported. The list below shows some more useful functions. - - -conversion from Isabelle-term to internal representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -... BITTE FORTSETZEN ... - -polynomial2expanded = ... -expanded2polynomial = ... - -remark: polynomial2expanded o expanded2polynomial = I, - where 'o' is function chaining, and 'I' is identity WN0210???SK - -functions for greatest common divisor and canceling -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -mv_gcd -factout_ -factout_p_ -cancel_ -cancel_p_ - -functions for least common multiple and addition of fractions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -mv_lcm -common_nominator_ -common_nominator_p_ -add_fraction_ (*.add 2 or more fractions.*) -add_fraction_p_ (*.add 2 or more fractions.*) - -functions for normalform of rationals -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -WN0210???SK interne Funktionen f"ur norm_rational: - schaffen diese SML-Funktionen wirklich ganz allgemeine Terme ? - -norm_rational_ -norm_expanded_rat_ - -**************************************************************************.*) - - -(*##*) -structure RationalI : RATIONALI = -struct -(*##*) - -infix mem ins union; (*WN100819 updating to Isabelle2009-2*) -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -fun (x ins xs) = if x mem xs then xs else x :: xs; -fun xs union [] = xs - | [] union ys = ys - | (x :: xs) union ys = xs union (x ins ys); - -(*. gcd of integers .*) -(* die gcd Funktion von Isabelle funktioniert nicht richtig !!! *) -fun gcd_int a b = if b=0 then a - else gcd_int b (a mod b); - -(*. univariate polynomials (uv) .*) -(*. univariate polynomials are represented as a list of the coefficent in reverse maximum degree order .*) -(*. 5 * x^5 + 4 * x^3 + 2 * x^2 + x + 19 => [19,1,2,4,0,5] .*) -type uv_poly = int list; - -(*. adds two uv polynomials .*) -fun uv_mod_add_poly ([]:uv_poly,p2:uv_poly) = p2:uv_poly - | uv_mod_add_poly (p1,[]) = p1 - | uv_mod_add_poly (x::p1,y::p2) = (x+y)::(uv_mod_add_poly(p1,p2)); - -(*. multiplies a uv polynomial with a skalar s .*) -fun uv_mod_smul_poly ([]:uv_poly,s:int) = []:uv_poly - | uv_mod_smul_poly (x::p,s) = (x*s)::(uv_mod_smul_poly(p,s)); - -(*. calculates the remainder of a polynomial divided by a skalar s .*) -fun uv_mod_rem_poly ([]:uv_poly,s) = []:uv_poly - | uv_mod_rem_poly (x::p,s) = (x mod s)::(uv_mod_smul_poly(p,s)); - -(*. calculates the degree of a uv polynomial .*) -fun uv_mod_deg ([]:uv_poly) = 0 - | uv_mod_deg p = length(p)-1; - -(*. calculates the remainder of x/p and represents it as value between -p/2 and p/2 .*) -fun uv_mod_mod2(x,p)= - let - val y=(x mod p); - in - if (y)>(p div 2) then (y)-p else - ( - if (y)<(~p div 2) then p+(y) else (y) - ) - end; - -(*.calculates the remainder for each element of a integer list divided by p.*) -fun uv_mod_list_modp [] p = [] - | uv_mod_list_modp (x::xs) p = (uv_mod_mod2(x,p))::(uv_mod_list_modp xs p); - -(*. appends an integer at the end of a integer list .*) -fun uv_mod_null (p1:int list,0) = p1 - | uv_mod_null (p1:int list,n1:int) = uv_mod_null(p1,n1-1) @ [0]; - -(*. uv polynomial division, result is (quotient, remainder) .*) -(*. only for uv_mod_divides .*) -(* FIXME: Division von x^9+x^5+1 durch x-1000 funktioniert nicht integer zu klein *) -fun uv_mod_pdiv (p1:uv_poly) ([]:uv_poly) = raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero") - | uv_mod_pdiv p1 [x] = - let - val xs=ref []; - in - if x<>0 then - ( - xs:=(uv_mod_rem_poly(p1,x)); - while length(!xs)>0 andalso hd(!xs)=0 do xs:=tl(!xs) - ) - else raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero"); - ([]:uv_poly,!xs:uv_poly) - end - | uv_mod_pdiv p1 p2 = - let - val n= uv_mod_deg(p2); - val m= ref (uv_mod_deg(p1)); - val p1'=ref (rev(p1)); - val p2'=(rev(p2)); - val lc2=hd(p2'); - val q=ref []; - val c=ref 0; - val output=ref ([],[]); - in - ( - if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: Division by zero") - else - ( - if (!m)=n do - ( - c:=hd(!p1') div hd(p2'); - if !c<>0 then - ( - p1':=uv_mod_add_poly(!p1',uv_mod_null(uv_mod_smul_poly(p2',~(!c)),!m-n)); - while length(!p1')>0 andalso hd(!p1')=0 do p1':= tl(!p1'); - m:=uv_mod_deg(!p1') - ) - else m:=0 - ); - output:=(rev(!q),rev(!p1')) - ) - ); - !output - ) - end; - -(*. divides p1 by p2 in Zp .*) -fun uv_mod_pdivp (p1:uv_poly) (p2:uv_poly) p = - let - val n=uv_mod_deg(p2); - val m=ref (uv_mod_deg(uv_mod_list_modp p1 p)); - val p1'=ref (rev(p1)); - val p2'=(rev(uv_mod_list_modp p2 p)); - val lc2=hd(p2'); - val q=ref []; - val c=ref 0; - val output=ref ([],[]); - in - ( - if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIVP_EXCEPTION: Division by zero") - else - ( - if (!m)=n do - ( - c:=uv_mod_mod2(hd(!p1')*(power lc2 1), p); - q:=(!c)::(!q); - p1':=uv_mod_list_modp(tl(uv_mod_add_poly(uv_mod_smul_poly(!p1',lc2), - uv_mod_smul_poly(uv_mod_smul_poly(p2',hd(!p1')),~1)))) p; - m:=(!m)-1 - ); - - while !p1'<>[] andalso hd(!p1')=0 do - ( - p1':=tl(!p1') - ); - - output:=(rev(uv_mod_list_modp (!q) (p)),rev(!p1')) - ) - ); - !output:uv_poly * uv_poly - ) - end; - -(*. calculates the remainder of p1/p2 .*) -fun uv_mod_prest (p1:uv_poly) ([]:uv_poly) = raise error("UV_MOD_PREST_EXCEPTION: Division by zero") - | uv_mod_prest [] p2 = []:uv_poly - | uv_mod_prest p1 p2 = (#2(uv_mod_pdiv p1 p2)); - -(*. calculates the remainder of p1/p2 in Zp .*) -fun uv_mod_prestp (p1:uv_poly) ([]:uv_poly) p= raise error("UV_MOD_PRESTP_EXCEPTION: Division by zero") - | uv_mod_prestp [] p2 p= []:uv_poly - | uv_mod_prestp p1 p2 p = #2(uv_mod_pdivp p1 p2 p); - -(*. calculates the content of a uv polynomial .*) -fun uv_mod_cont ([]:uv_poly) = 0 - | uv_mod_cont (x::p)= gcd_int x (uv_mod_cont(p)); - -(*. divides each coefficient of a uv polynomial by y .*) -fun uv_mod_div_list (p:uv_poly,0) = raise error("UV_MOD_DIV_LIST_EXCEPTION: Division by zero") - | uv_mod_div_list ([],y) = []:uv_poly - | uv_mod_div_list (x::p,y) = (x div y)::uv_mod_div_list(p,y); - -(*. calculates the primitiv part of a uv polynomial .*) -fun uv_mod_pp ([]:uv_poly) = []:uv_poly - | uv_mod_pp p = - let - val c=ref 0; - in - ( - c:=uv_mod_cont(p); - - if !c=0 then raise error ("RATIONALS_UV_MOD_PP_EXCEPTION: content is 0") - else uv_mod_div_list(p,!c) - ) - end; - -(*. gets the leading coefficient of a uv polynomial .*) -fun uv_mod_lc ([]:uv_poly) = 0 - | uv_mod_lc p = hd(rev(p)); - -(*. calculates the euklidean polynomial remainder sequence in Zp .*) -fun uv_mod_prs_euklid_p(p1:uv_poly,p2:uv_poly,p)= - let - val f =ref []; - val f'=ref p2; - val fi=ref []; - in - ( - f:=p2::p1::[]; - while uv_mod_deg(!f')>0 do - ( - f':=uv_mod_prestp (hd(tl(!f))) (hd(!f)) p; - if (!f')<>[] then - ( - fi:=(!f'); - f:=(!fi)::(!f) - ) - else () - ); - (!f) - - ) - end; - -(*. calculates the gcd of p1 and p2 in Zp .*) -fun uv_mod_gcd_modp ([]:uv_poly) (p2:uv_poly) p = p2:uv_poly - | uv_mod_gcd_modp p1 [] p= p1 - | uv_mod_gcd_modp p1 p2 p= - let - val p1'=ref[]; - val p2'=ref[]; - val pc=ref[]; - val g=ref []; - val d=ref 0; - val prs=ref []; - in - ( - if uv_mod_deg(p1)>=uv_mod_deg(p2) then - ( - p1':=uv_mod_list_modp (uv_mod_pp(p1)) p; - p2':=uv_mod_list_modp (uv_mod_pp(p2)) p - ) - else - ( - p1':=uv_mod_list_modp (uv_mod_pp(p2)) p; - p2':=uv_mod_list_modp (uv_mod_pp(p1)) p - ); - d:=uv_mod_mod2((gcd_int (uv_mod_cont(p1))) (uv_mod_cont(p2)), p) ; - if !d>(p div 2) then d:=(!d)-p else (); - - prs:=uv_mod_prs_euklid_p(!p1',!p2',p); - - if hd(!prs)=[] then pc:=hd(tl(!prs)) - else pc:=hd(!prs); - - g:=uv_mod_smul_poly(uv_mod_pp(!pc),!d); - !g - ) - end; - -(*. calculates the minimum of two real values x and y .*) -fun uv_mod_r_min(x,y):BasisLibrary.Real.real = if x>y then y else x; - -(*. calculates the minimum of two integer values x and y .*) -fun uv_mod_min(x,y) = if x>y then y else x; - -(*. adds the squared values of a integer list .*) -fun uv_mod_add_qu [] = 0.0 - | uv_mod_add_qu (x::p) = BasisLibrary.Real.fromInt(x)*BasisLibrary.Real.fromInt(x) + uv_mod_add_qu p; - -(*. calculates the euklidean norm .*) -fun uv_mod_norm ([]:uv_poly) = 0.0 - | uv_mod_norm p = Math.sqrt(uv_mod_add_qu(p)); - -(*. multipies two values a and b .*) -fun uv_mod_multi a b = a * b; - -(*. decides if x is a prim, the list contains all primes which are lower then x .*) -fun uv_mod_prim(x,[])= false - | uv_mod_prim(x,[y])=if ((x mod y) <> 0) then true - else false - | uv_mod_prim(x,y::ys) = if uv_mod_prim(x,[y]) - then - if uv_mod_prim(x,ys) then true - else false - else false; - -(*. gets the first prime, which is greater than p and does not divide g .*) -fun uv_mod_nextprime(g,p)= - let - val list=ref [2]; - val exit=ref 0; - val i = ref 2 - in - while (!i 0) - then - ( - list:= (!i)::(!list); - i:= (!i)+1 - ) - else i:=(!i)+1 - ) - else i:= (!i)+1 - ); - i:=(p+1); - while (!exit=0) do (* calculate next prime which does not divide g *) - ( - if uv_mod_prim(!i,!list) then - ( - if (g mod !i <> 0) - then - ( - list:= (!i)::(!list); - exit:= (!i) - ) - else i:=(!i)+1 - ) - else i:= (!i)+1 - ); - !exit - end; - -(*. decides if p1 is a factor of p2 in Zp .*) -fun uv_mod_dividesp ([]:uv_poly) (p2:uv_poly) p= raise error("UV_MOD_DIVIDESP: Division by zero") - | uv_mod_dividesp p1 p2 p= if uv_mod_prestp p2 p1 p = [] then true else false; - -(*. decides if p1 is a factor of p2 .*) -fun uv_mod_divides ([]:uv_poly) (p2:uv_poly) = raise error("UV_MOD_DIVIDES: Division by zero") - | uv_mod_divides p1 p2 = if uv_mod_prest p2 p1 = [] then true else false; - -(*. chinese remainder algorithm .*) -fun uv_mod_cra2(r1,r2,m1,m2)= - let - val c=ref 0; - val r1'=ref 0; - val d=ref 0; - val a=ref 0; - in - ( - while (uv_mod_mod2((!c)*m1,m2))<>1 do - ( - c:=(!c)+1 - ); - r1':= uv_mod_mod2(r1,m1); - d:=uv_mod_mod2(((r2-(!r1'))*(!c)),m2); - !r1'+(!d)*m1 - ) - end; - -(*. applies the chinese remainder algorithmen to the coefficients of x1 and x2 .*) -fun uv_mod_cra_2 ([],[],m1,m2) = [] - | uv_mod_cra_2 ([],x2,m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x1") - | uv_mod_cra_2 (x1,[],m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x2") - | 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)); - -(*. calculates the gcd of two uv polynomials p1' and p2' with the modular algorithm .*) -fun uv_mod_gcd (p1':uv_poly) (p2':uv_poly) = - let - val p1=ref (uv_mod_pp(p1')); - val p2=ref (uv_mod_pp(p2')); - val c=gcd_int (uv_mod_cont(p1')) (uv_mod_cont(p2')); - val temp=ref []; - val cp=ref []; - val qp=ref []; - val q=ref[]; - val pn=ref 0; - val d=ref 0; - val g1=ref 0; - val p=ref 0; - val m=ref 0; - val exit=ref 0; - val i=ref 1; - in - if length(!p1)>length(!p2) then () - else - ( - temp:= !p1; - p1:= !p2; - p2:= !temp - ); - - - d:=gcd_int (uv_mod_lc(!p1)) (uv_mod_lc(!p2)); - g1:=uv_mod_lc(!p1)*uv_mod_lc(!p2); - p:=4; - - m:=BasisLibrary.Real.ceil(2.0 * - BasisLibrary.Real.fromInt(!d) * - BasisLibrary.Real.fromInt(power 2 (uv_mod_min(uv_mod_deg(!p2),uv_mod_deg(!p1)))) * - BasisLibrary.Real.fromInt(!d) * - uv_mod_r_min(uv_mod_norm(!p1) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p1))), - uv_mod_norm(!p2) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p2))))); - - while (!exit=0) do - ( - p:=uv_mod_nextprime(!d,!p); - cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)) ; - if abs(uv_mod_lc(!cp))<>1 then (* leading coefficient = 1 ? *) - ( - i:=1; - while (!i)<(!p) andalso (abs(uv_mod_mod2((uv_mod_lc(!cp)*(!i)),(!p)))<>1) do - ( - i:=(!i)+1 - ); - cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p) - ) - else (); - - qp:= ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp)); - - if uv_mod_deg(!qp)=0 then (q:=[1]; exit:=1) else (); - - pn:=(!p); - q:=(!qp); - - while !pn<= !m andalso !m>(!p) andalso !exit=0 do - ( - p:=uv_mod_nextprime(!d,!p); - cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)); - if uv_mod_lc(!cp)<>1 then (* leading coefficient = 1 ? *) - ( - i:=1; - while (!i)<(!p) andalso ((uv_mod_mod2((uv_mod_lc(!q)*(!i)),(!p)))<>1) do - ( - i:=(!i)+1 - ); - cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p) - ) - else (); - - qp:=uv_mod_list_modp ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp) ) (!p); - if uv_mod_deg(!qp)>uv_mod_deg(!q) then - ( - (*print("degree to high!!!\n")*) - ) - else - ( - if uv_mod_deg(!qp)=uv_mod_deg(!q) then - ( - q:=uv_mod_cra_2(!q,!qp,!pn,!p); - pn:=(!pn) * !p; - q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn)); (* found already gcd ? *) - if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then (exit:=1) else () - ) - else - ( - if uv_mod_deg(!qp) [(5,[5,3,0]),(4,[3,0,2]),(2,[2,1,3]),(~1,[0,0,1]),(~19,[0,0,0])] .*) - -(*. global variables .*) -(*. order indicators .*) -val LEX_=0; (* lexicographical term order *) -val GGO_=1; (* greatest degree order *) - -(*. datatypes for internal representation.*) -type mv_monom = (int * (*.coefficient or the monom.*) - int list); (*.list of exponents) .*) -fun mv_monom2str (i, is) = "("^ int2str i^"," ^ ints2str' is ^ ")"; - -type mv_poly = mv_monom list; -fun mv_poly2str p = (strs2str' o (map mv_monom2str)) p; - -(*. help function for monom_greater and geq .*) -fun mv_mg_hlp([]) = EQUAL - | mv_mg_hlp(x::list)=if x<0 then LESS - else if x>0 then GREATER - else mv_mg_hlp(list); - -(*. adds a list of values .*) -fun mv_addlist([]) = 0 - | mv_addlist(p1) = hd(p1)+mv_addlist(tl(p1)); - -(*. tests if the monomial M1 is greater as the monomial M2 and returns a boolean value .*) -(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*) -fun mv_monom_greater((M1x,M1l):mv_monom,(M2x,M2l):mv_monom,order)= - if order=LEX_ then - ( - if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error") - else if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true - ) - else - if order=GGO_ then - ( - if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error") - else - if mv_addlist(M1l)=mv_addlist(M2l) then if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true - else if mv_addlist(M1l)>mv_addlist(M2l) then true else false - ) - else raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Wrong Order"); - -(*. tests if the monomial X is greater as the monomial Y and returns a order value (GREATER,EQUAL,LESS) .*) -(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*) -fun mv_geq order ((x1,x):mv_monom,(x2,y):mv_monom) = -let - val temp=ref EQUAL; -in - if order=LEX_ then - ( - if length(x)<>length(y) then - raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error") - else - ( - temp:=mv_mg_hlp((map op- (x~~y))); - if !temp=EQUAL then - ( if x1=x2 then EQUAL - else if x1>x2 then GREATER - else LESS - ) - else (!temp) - ) - ) - else - if order=GGO_ then - ( - if length(x)<>length(y) then - raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error") - else - if mv_addlist(x)=mv_addlist(y) then - (mv_mg_hlp((map op- (x~~y)))) - else if mv_addlist(x)>mv_addlist(y) then GREATER else LESS - ) - else raise error ("RATIONALS_MV_GEQ_EXCEPTION: Wrong Order") -end; - -(*. cuts the first variable from a polynomial .*) -fun mv_cut([]:mv_poly)=[]:mv_poly - | mv_cut((x,[])::list) = raise error ("RATIONALS_MV_CUT_EXCEPTION: Invalid list ") - | mv_cut((x,y::ys)::list)=(x,ys)::mv_cut(list); - -(*. leading power product .*) -fun mv_lpp([]:mv_poly,order) = [] - | mv_lpp([(x,y)],order) = y - | mv_lpp(p1,order) = #2(hd(rev(sort (mv_geq order) p1))); - -(*. leading monomial .*) -fun mv_lm([]:mv_poly,order) = (0,[]):mv_monom - | mv_lm([x],order) = x - | mv_lm(p1,order) = hd(rev(sort (mv_geq order) p1)); - -(*. leading coefficient in term order .*) -fun mv_lc2([]:mv_poly,order) = 0 - | mv_lc2([(x,y)],order) = x - | mv_lc2(p1,order) = #1(hd(rev(sort (mv_geq order) p1))); - - -(*. reverse the coefficients in mv polynomial .*) -fun mv_rev_to([]:mv_poly) = []:mv_poly - | mv_rev_to((c,e)::xs) = (c,rev(e))::mv_rev_to(xs); - -(*. leading coefficient in reverse term order .*) -fun mv_lc([]:mv_poly,order) = []:mv_poly - | mv_lc([(x,y)],order) = mv_rev_to(mv_cut(mv_rev_to([(x,y)]))) - | mv_lc(p1,order) = - let - val p1o=ref (rev(sort (mv_geq order) (mv_rev_to(p1)))); - val lp=hd(#2(hd(!p1o))); - val lc=ref []; - in - ( - while (length(!p1o)>0 andalso hd(#2(hd(!p1o)))=lp) do - ( - lc:=hd(mv_cut([hd(!p1o)]))::(!lc); - p1o:=tl(!p1o) - ); - if !lc=[] then raise error ("RATIONALS_MV_LC_EXCEPTION: lc is empty") else (); - mv_rev_to(!lc) - ) - end; - -(*. compares two powerproducts .*) -fun mv_monom_equal((_,xlist):mv_monom,(_,ylist):mv_monom) = (foldr and_) (((map op=) (xlist~~ylist)),true); - -(*. help function for mv_add .*) -fun mv_madd([]:mv_poly,[]:mv_poly,order) = []:mv_poly - | mv_madd([(0,_)],p2,order) = p2 - | mv_madd(p1,[(0,_)],order) = p1 - | mv_madd([],p2,order) = p2 - | mv_madd(p1,[],order) = p1 - | mv_madd(p1,p2,order) = - ( - if mv_monom_greater(hd(p1),hd(p2),order) - then hd(p1)::mv_madd(tl(p1),p2,order) - else if mv_monom_equal(hd(p1),hd(p2)) - then if mv_lc2(p1,order)+mv_lc2(p2,order)<>0 - then (mv_lc2(p1,order)+mv_lc2(p2,order),mv_lpp(p1,order))::mv_madd(tl(p1),tl(p2),order) - else mv_madd(tl(p1),tl(p2),order) - else hd(p2)::mv_madd(p1,tl(p2),order) - ) - -(*. adds two multivariate polynomials .*) -fun mv_add([]:mv_poly,p2:mv_poly,order) = p2 - | mv_add(p1,[],order) = p1 - | mv_add(p1,p2,order) = mv_madd(rev(sort (mv_geq order) p1),rev(sort (mv_geq order) p2), order); - -(*. monom multiplication .*) -fun mv_mmul((x1,y1):mv_monom,(x2,y2):mv_monom)=(x1*x2,(map op+) (y1~~y2)):mv_monom; - -(*. deletes all monomials with coefficient 0 .*) -fun mv_shorten([]:mv_poly,order) = []:mv_poly - | mv_shorten(x::xs,order)=mv_madd([x],mv_shorten(xs,order),order); - -(*. zeros a list .*) -fun mv_null2([])=[] - | mv_null2(x::l)=0::mv_null2(l); - -(*. multiplies two multivariate polynomials .*) -fun mv_mul([]:mv_poly,[]:mv_poly,_) = []:mv_poly - | mv_mul([],y::p2,_) = [(0,mv_null2(#2(y)))] - | mv_mul(x::p1,[],_) = [(0,mv_null2(#2(x)))] - | mv_mul(x::p1,y::p2,order) = mv_shorten(rev(sort (mv_geq order) (mv_mmul(x,y) :: (mv_mul(p1,y::p2,order) @ - mv_mul([x],p2,order)))),order); - -(*. gets the maximum value of a list .*) -fun mv_getmax([])=0 - | mv_getmax(x::p1)= let - val m=mv_getmax(p1); - in - if m>x then m - else x - end; -(*. calculates the maximum degree of an multivariate polynomial .*) -fun mv_grad([]:mv_poly) = 0 - | mv_grad(p1:mv_poly)= mv_getmax((map mv_addlist) ((map #2) p1)); - -(*. converts the sign of a value .*) -fun mv_minus(x)=(~1) * x; - -(*. converts the sign of all coefficients of a polynomial .*) -fun mv_minus2([]:mv_poly)=[]:mv_poly - | mv_minus2(p1)=(mv_minus(#1(hd(p1))),#2(hd(p1)))::(mv_minus2(tl(p1))); - -(*. searches for a negativ value in a list .*) -fun mv_is_negativ([])=false - | mv_is_negativ(x::xs)=if x<0 then true else mv_is_negativ(xs); - -(*. division of monomials .*) -fun mv_mdiv((0,[]):mv_monom,_:mv_monom)=(0,[]):mv_monom - | mv_mdiv(_,(0,[]))= raise error ("RATIONALS_MV_MDIV_EXCEPTION Division by 0 ") - | mv_mdiv(p1:mv_monom,p2:mv_monom)= - let - val c=ref (#1(p2)); - val pp=ref []; - in - ( - if !c=0 then raise error("MV_MDIV_EXCEPTION Dividing by zero") - else c:=(#1(p1) div #1(p2)); - if #1(p2)<>0 then - ( - pp:=(#2(mv_mmul((1,#2(p1)),(1,(map mv_minus) (#2(p2)))))); - if mv_is_negativ(!pp) then (0,!pp) - else (!c,!pp) - ) - else raise error("MV_MDIV_EXCEPTION Dividing by empty Polynom") - ) - end; - -(*. prints a polynom for (internal use only) .*) -fun mv_print_poly([]:mv_poly)=print("[]\n") - | mv_print_poly((x,y)::[])= print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^")\n") - | mv_print_poly((x,y)::p1) = (print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^"),");mv_print_poly(p1)); - - -(*. division of two multivariate polynomials .*) -fun mv_division([]:mv_poly,g:mv_poly,order)=([]:mv_poly,[]:mv_poly) - | mv_division(f,[],order)= raise error ("RATIONALS_MV_DIVISION_EXCEPTION Division by zero") - | mv_division(f,g,order)= - let - val r=ref []; - val q=ref []; - val g'=ref []; - val k=ref 0; - val m=ref (0,[0]); - val exit=ref 0; - in - r := rev(sort (mv_geq order) (mv_shorten(f,order))); - g':= rev(sort (mv_geq order) (mv_shorten(g,order))); - if #1(hd(!g'))=0 then raise error("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero") else (); - if (mv_monom_greater (hd(!g'),hd(!r),order)) then ([(0,mv_null2(#2(hd(f))))],(!r)) - else - ( - exit:=0; - while (if (!exit)=0 then not(mv_monom_greater (hd(!g'),hd(!r),order)) else false) do - ( - if (#1(mv_lm(!g',order)))<>0 then m:=mv_mdiv(mv_lm(!r,order),mv_lm(!g',order)) - else raise error ("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero"); - if #1(!m)<>0 then - ( - q:=(!m)::(!q); - r:=mv_add((!r),mv_minus2(mv_mul(!g',[!m],order)),order) - ) - else exit:=1; - if (if length(!r)<>0 then length(!g')<>0 else false) then () - else (exit:=1) - ); - (rev(!q),!r) - ) - end; - -(*. multiplies a polynomial with an integer .*) -fun mv_skalar_mul([]:mv_poly,c) = []:mv_poly - | mv_skalar_mul((x,y)::p1,c) = ((x * c),y)::mv_skalar_mul(p1,c); - -(*. inserts the a first variable into an polynomial with exponent v .*) -fun mv_correct([]:mv_poly,v:int)=[]:mv_poly - | mv_correct((x,y)::list,v:int)=(x,v::y)::mv_correct(list,v); - -(*. multivariate case .*) - -(*. decides if x is a factor of y .*) -fun mv_divides([]:mv_poly,[]:mv_poly)= raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero") - | mv_divides(x,[]) = raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero") - | mv_divides(x:mv_poly,y:mv_poly) = #2(mv_division(y,x,LEX_))=[]; - -(*. gets the maximum of a and b .*) -fun mv_max(a,b) = if a>b then a else b; - -(*. gets the maximum exponent of a mv polynomial in the lexicographic term order .*) -fun mv_deg([]:mv_poly) = 0 - | mv_deg(p1)= - let - val p1'=mv_shorten(p1,LEX_); - in - if length(p1')=0 then 0 - else mv_max(hd(#2(hd(p1'))),mv_deg(tl(p1'))) - end; - -(*. gets the maximum exponent of a mv polynomial in the reverse lexicographic term order .*) -fun mv_deg2([]:mv_poly) = 0 - | mv_deg2(p1)= - let - val p1'=mv_shorten(p1,LEX_); - in - if length(p1')=0 then 0 - else mv_max(hd(rev(#2(hd(p1')))),mv_deg2(tl(p1'))) - end; - -(*. evaluates the mv polynomial at the value v of the main variable .*) -fun mv_subs([]:mv_poly,v) = []:mv_poly - | mv_subs((c,e)::p1:mv_poly,v) = mv_skalar_mul(mv_cut([(c,e)]),power v (hd(e))) @ mv_subs(p1,v); - -(*. calculates the content of a uv-polynomial in mv-representation .*) -fun uv_content2([]:mv_poly) = 0 - | uv_content2((c,e)::p1) = (gcd_int c (uv_content2(p1))); - -(*. converts a uv-polynomial from mv-representation to uv-representation .*) -fun uv_to_list ([]:mv_poly)=[]:uv_poly - | uv_to_list ((c1,e1)::others) = - let - val count=ref 0; - val max=mv_grad((c1,e1)::others); - val help=ref ((c1,e1)::others); - val list=ref []; - in - if length(e1)>1 then raise error ("RATIONALS_TO_LIST_EXCEPTION: not univariate") - else if length(e1)=0 then [c1] - else - ( - count:=0; - while (!count)<=max do - ( - if length(!help)>0 andalso hd(#2(hd(!help)))=max-(!count) then - ( - list:=(#1(hd(!help)))::(!list); - help:=tl(!help) - ) - else - ( - list:= 0::(!list) - ); - count := (!count) + 1 - ); - (!list) - ) - end; - -(*. converts a uv-polynomial from uv-representation to mv-representation .*) -fun uv_to_poly ([]:uv_poly) = []:mv_poly - | uv_to_poly p1 = - let - val count=ref 0; - val help=ref p1; - val list=ref []; - in - while length(!help)>0 do - ( - if hd(!help)=0 then () - else list:=(hd(!help),[!count])::(!list); - count:=(!count)+1; - help:=tl(!help) - ); - (!list) - end; - -(*. univariate gcd calculation from polynomials in multivariate representation .*) -fun uv_gcd ([]:mv_poly) p2 = p2 - | uv_gcd p1 ([]:mv_poly) = p1 - | uv_gcd p1 [(c,[e])] = - let - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_)))); - val min=uv_mod_min(e,(hd(#2(hd(rev(!list)))))); - in - [(gcd_int (uv_content2(p1)) c,[min])] - end - | uv_gcd [(c,[e])] p2 = - let - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p2,LEX_)))); - val min=uv_mod_min(e,(hd(#2(hd(rev(!list)))))); - in - [(gcd_int (uv_content2(p2)) c,[min])] - end - | uv_gcd p11 p22 = uv_to_poly(uv_mod_gcd (uv_to_list(mv_shorten(p11,LEX_))) (uv_to_list(mv_shorten(p22,LEX_)))); - -(*. help function for the newton interpolation .*) -fun mv_newton_help ([]:mv_poly list,k:int) = []:mv_poly list - | mv_newton_help (pl:mv_poly list,k) = - let - val x=ref (rev(pl)); - val t=ref []; - val y=ref []; - val n=ref 1; - val n1=ref[]; - in - ( - while length(!x)>1 do - ( - if length(hd(!x))>0 then n1:=mv_null2(#2(hd(hd(!x)))) - else if length(hd(tl(!x)))>0 then n1:=mv_null2(#2(hd(hd(tl(!x))))) - else n1:=[]; - t:= #1(mv_division(mv_add(hd(!x),mv_skalar_mul(hd(tl(!x)),~1),LEX_),[(k,!n1)],LEX_)); - y:=(!t)::(!y); - x:=tl(!x) - ); - (!y) - ) - end; - -(*. help function for the newton interpolation .*) -fun mv_newton_add ([]:mv_poly list) t = []:mv_poly - | mv_newton_add [x:mv_poly] t = x - | mv_newton_add (pl:mv_poly list) t = - let - val expos=ref []; - val pll=ref pl; - in - ( - - while length(!pll)>0 andalso hd(!pll)=[] do - ( - pll:=tl(!pll) - ); - if length(!pll)>0 then expos:= #2(hd(hd(!pll))) else expos:=[]; - mv_add(hd(pl), - mv_mul( - mv_add(mv_correct(mv_cut([(1,mv_null2(!expos))]),1),[(~t,mv_null2(!expos))],LEX_), - mv_newton_add (tl(pl)) (t+1), - LEX_ - ), - LEX_) - ) - end; - -(*. calculates the newton interpolation with polynomial coefficients .*) -(*. step-depth is 1 and if the result is not an integerpolynomial .*) -(*. this function returns [] .*) -fun mv_newton ([]:(mv_poly) list) = []:mv_poly - | mv_newton ([mp]:(mv_poly) list) = mp:mv_poly - | mv_newton pl = - let - val c=ref pl; - val c1=ref []; - val n=length(pl); - val k=ref 1; - val i=ref n; - val ppl=ref []; - in - c1:=hd(pl)::[]; - c:=mv_newton_help(!c,!k); - c1:=(hd(!c))::(!c1); - while(length(!c)>1 andalso !k0 andalso hd(!c)=[] do c:=tl(!c); - if !c=[] then () else c:=mv_newton_help(!c,!k); - ppl:= !c; - if !c=[] then () else c1:=(hd(!c))::(!c1) - ); - while hd(!c1)=[] do c1:=tl(!c1); - c1:=rev(!c1); - ppl:= !c1; - mv_newton_add (!c1) 1 - end; - -(*. sets the exponents of the first variable to zero .*) -fun mv_null3([]:mv_poly) = []:mv_poly - | mv_null3((x,y)::xs) = (x,0::tl(y))::mv_null3(xs); - -(*. calculates the minimum exponents of a multivariate polynomial .*) -fun mv_min_pp([]:mv_poly)=[] - | mv_min_pp((c,e)::xs)= - let - val y=ref xs; - val x=ref []; - in - ( - x:=e; - while length(!y)>0 do - ( - x:=(map uv_mod_min) ((!x) ~~ (#2(hd(!y)))); - y:=tl(!y) - ); - !x - ) - end; - -(*. checks if all elements of the list have value zero .*) -fun list_is_null [] = true - | list_is_null (x::xs) = (x=0 andalso list_is_null(xs)); - -(* check if main variable is zero*) -fun main_zero (ms : mv_poly) = (list_is_null o (map (hd o #2))) ms; - -(*. calculates the content of an polynomial .*) -fun mv_content([]:mv_poly) = []:mv_poly - | mv_content(p1) = - let - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_)))); - val test=ref (hd(#2(hd(!list)))); - val result=ref []; - val min=(hd(#2(hd(rev(!list))))); - in - ( - if length(!list)>1 then - ( - while (if length(!list)>0 then (hd(#2(hd(!list)))=(!test)) else false) do - ( - result:=(#1(hd(!list)),tl(#2(hd(!list))))::(!result); - - if length(!list)<1 then list:=[] - else list:=tl(!list) - - ); - if length(!list)>0 then - ( - list:=mv_gcd (!result) (mv_cut(mv_content(!list))) - ) - else list:=(!result); - list:=mv_correct(!list,0); - (!list) - ) - else - ( - mv_null3(!list) - ) - ) - end - -(*. calculates the primitiv part of a polynomial .*) -and mv_pp([]:mv_poly) = []:mv_poly - | mv_pp(p1) = let - val cont=ref []; - val pp=ref[]; - in - cont:=mv_content(p1); - pp:=(#1(mv_division(p1,!cont,LEX_))); - if !pp=[] - then raise error("RATIONALS_MV_PP_EXCEPTION: Invalid Content ") - else (!pp) - end - -(*. calculates the gcd of two multivariate polynomials with a modular approach .*) -and mv_gcd ([]:mv_poly) ([]:mv_poly) :mv_poly= []:mv_poly - | mv_gcd ([]:mv_poly) (p2) :mv_poly= p2:mv_poly - | mv_gcd (p1:mv_poly) ([]) :mv_poly= p1:mv_poly - | mv_gcd ([(x,xs)]:mv_poly) ([(y,ys)]):mv_poly = - let - val xpoly:mv_poly = [(x,xs)]; - val ypoly:mv_poly = [(y,ys)]; - in - ( - if xs=ys then [((gcd_int x y),xs)] - else [((gcd_int x y),(map uv_mod_min)(xs~~ys))]:mv_poly - ) - end - | mv_gcd (p1:mv_poly) ([(y,ys)]) :mv_poly= - ( - [(gcd_int (uv_content2(p1)) (y),(map uv_mod_min)(mv_min_pp(p1)~~ys))]:mv_poly - ) - | mv_gcd ([(y,ys)]:mv_poly) (p2):mv_poly = - ( - [(gcd_int (uv_content2(p2)) (y),(map uv_mod_min)(mv_min_pp(p2)~~ys))]:mv_poly - ) - | mv_gcd (p1':mv_poly) (p2':mv_poly):mv_poly= - let - val vc=length(#2(hd(p1'))); - val cont = - ( - if main_zero(mv_content(p1')) andalso - (main_zero(mv_content(p2'))) then - mv_correct((mv_gcd (mv_cut(mv_content(p1'))) (mv_cut(mv_content(p2')))),0) - else - mv_gcd (mv_content(p1')) (mv_content(p2')) - ); - val p1= #1(mv_division(p1',mv_content(p1'),LEX_)); - val p2= #1(mv_division(p2',mv_content(p2'),LEX_)); - val gcd=ref []; - val candidate=ref []; - val interpolation_list=ref []; - val delta=ref []; - val p1r = ref []; - val p2r = ref []; - val p1r' = ref []; - val p2r' = ref []; - val factor=ref []; - val r=ref 0; - val gcd_r=ref []; - val d=ref 0; - val exit=ref 0; - val current_degree=ref 99999; (*. FIXME: unlimited ! .*) - in - ( - if vc<2 then (* areUnivariate(p1',p2') *) - ( - gcd:=uv_gcd (mv_shorten(p1',LEX_)) (mv_shorten(p2',LEX_)) - ) - else - ( - while !exit=0 do - ( - r:=(!r)+1; - p1r := mv_lc(p1,LEX_); - p2r := mv_lc(p2,LEX_); - if main_zero(!p1r) andalso - main_zero(!p2r) - then - ( - delta := mv_correct((mv_gcd (mv_cut (!p1r)) (mv_cut (!p2r))),0) - ) - else - ( - delta := mv_gcd (!p1r) (!p2r) - ); - (*if mv_shorten(mv_subs(!p1r,!r),LEX_)=[] andalso - mv_shorten(mv_subs(!p2r,!r),LEX_)=[] *) - if mv_lc2(mv_shorten(mv_subs(!p1r,!r),LEX_),LEX_)=0 andalso - mv_lc2(mv_shorten(mv_subs(!p2r,!r),LEX_),LEX_)=0 - then - ( - ) - else - ( - gcd_r:=mv_shorten(mv_gcd (mv_shorten(mv_subs(p1,!r),LEX_)) - (mv_shorten(mv_subs(p2,!r),LEX_)) ,LEX_); - gcd_r:= #1(mv_division(mv_mul(mv_correct(mv_subs(!delta,!r),0),!gcd_r,LEX_), - mv_correct(mv_lc(!gcd_r,LEX_),0),LEX_)); - d:=mv_deg2(!gcd_r); (* deg(gcd_r,z) *) - if (!d < !current_degree) then - ( - current_degree:= !d; - interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list) - ) - else - ( - if (!d = !current_degree) then - ( - interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list) - ) - else () - ) - ); - if length(!interpolation_list)> uv_mod_min(mv_deg(p1),mv_deg(p2)) then - ( - candidate := mv_newton(rev(!interpolation_list)); - if !candidate=[] then () - else - ( - candidate:=mv_pp(!candidate); - if mv_divides(!candidate,p1) andalso mv_divides(!candidate,p2) then - ( - gcd:= mv_mul(!candidate,cont,LEX_); - exit:=1 - ) - else () - ); - interpolation_list:=[mv_correct(!gcd_r,0)] - ) - else () - ) - ); - (!gcd):mv_poly - ) - end; - - -(*. calculates the least common divisor of two polynomials .*) -fun mv_lcm (p1:mv_poly) (p2:mv_poly) :mv_poly = - ( - #1(mv_division(mv_mul(p1,p2,LEX_),mv_gcd p1 p2,LEX_)) - ); - -(*. gets the variables (strings) of a term .*) -fun get_vars(term1) = (map free2str) (vars term1); (*["a","b","c"]; *) - -(*. counts the negative coefficents in a polynomial .*) -fun count_neg ([]:mv_poly) = 0 - | count_neg ((c,e)::xs) = if c<0 then 1+count_neg xs - else count_neg xs; - -(*. help function for is_polynomial - checks the order of the operators .*) -fun test_polynomial (Const ("uminus",_) $ Free (str,_)) _ = true (*WN.13.3.03*) - | test_polynomial (t as Free(str,_)) v = true - | test_polynomial (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false - else (test_polynomial t1 "*") andalso (test_polynomial t2 "*") - | test_polynomial (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false - else (test_polynomial t1 " ") andalso (test_polynomial t2 " ") - | test_polynomial (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_polynomial t1 "^") andalso (test_polynomial t2 "^") - | test_polynomial _ v = false; - -(*. tests if a term is a polynomial .*) -fun is_polynomial t = test_polynomial t " "; - -(*. help function for is_expanded - checks the order of the operators .*) -fun test_exp (t as Free(str,_)) v = true - | test_exp (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false - else (test_exp t1 "*") andalso (test_exp t2 "*") - | test_exp (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false - else (test_exp t1 " ") andalso (test_exp t2 " ") - | test_exp (t as Const ("op -",_) $ t1 $ t2) v = if v="*" orelse v="^" then false - else (test_exp t1 " ") andalso (test_exp t2 " ") - | test_exp (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_exp t1 "^") andalso (test_exp t2 "^") - | test_exp _ v = false; - - -(*. help function for check_coeff: - converts the term to a list of coefficients .*) -fun term2coef' (t as Free(str,_(*typ*))) v :mv_poly option = - let - val x=ref NONE; - val len=ref 0; - val vl=ref []; - val vh=ref []; - val i=ref 0; - in - if is_numeral str then - ( - SOME [(((the o int_of_str) str),mv_null2(v))] handle _ => NONE - ) - else (* variable *) - ( - len:=length(v); - vh:=v; - while ((!len)>(!i)) do - ( - if str=hd((!vh)) then - ( - vl:=1::(!vl) - ) - else - ( - vl:=0::(!vl) - ); - vh:=tl(!vh); - i:=(!i)+1 - ); - SOME [(1,rev(!vl))] handle _ => NONE - ) - end - | term2coef' (Const ("op *",_) $ t1 $ t2) v :mv_poly option= - let - val t1pp=ref []; - val t2pp=ref []; - val t1c=ref 0; - val t2c=ref 0; - in - ( - t1pp:=(#2(hd(the(term2coef' t1 v)))); - t2pp:=(#2(hd(the(term2coef' t2 v)))); - t1c:=(#1(hd(the(term2coef' t1 v)))); - t2c:=(#1(hd(the(term2coef' t2 v)))); - - SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] handle _ => NONE - - ) - end - | term2coef' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ (t2 as Free (str2,_))) v :mv_poly option= - let - val x=ref NONE; - val len=ref 0; - val vl=ref []; - val vh=ref []; - val vtemp=ref []; - val i=ref 0; - in - ( - if (not o is_numeral) str1 andalso is_numeral str2 then - ( - len:=length(v); - vh:=v; - - while ((!len)>(!i)) do - ( - if str1=hd((!vh)) then - ( - vl:=((the o int_of_str) str2)::(!vl) - ) - else - ( - vl:=0::(!vl) - ); - vh:=tl(!vh); - i:=(!i)+1 - ); - SOME [(1,rev(!vl))] handle _ => NONE - ) - else raise error ("RATIONALS_TERM2COEF_EXCEPTION 1: Invalid term") - ) - end - | term2coef' (Const ("op +",_) $ t1 $ t2) v :mv_poly option= - ( - SOME ((the(term2coef' t1 v)) @ (the(term2coef' t2 v))) handle _ => NONE - ) - | term2coef' (Const ("op -",_) $ t1 $ t2) v :mv_poly option= - ( - SOME ((the(term2coef' t1 v)) @ mv_skalar_mul((the(term2coef' t2 v)),1)) handle _ => NONE - ) - | term2coef' (term) v = raise error ("RATIONALS_TERM2COEF_EXCEPTION 2: Invalid term"); - -(*. checks if all coefficients of a polynomial are positiv (except the first) .*) -fun check_coeff t = (* erste Koeffizient kann <0 sein !!! *) - if count_neg(tl(the(term2coef' t (get_vars(t)))))=0 then true - else false; - -(*. checks for expanded term [3] .*) -fun is_expanded t = test_exp t " " andalso check_coeff(t); - -(*WN.7.3.03 Hilfsfunktion f"ur term2poly'*) -fun mk_monom v' p vs = - let fun conv p (v: string) = if v'= v then p else 0 - in map (conv p) vs end; -(* mk_monom "y" 5 ["a","b","x","y","z"]; -val it = [0,0,0,5,0] : int list*) - -(*. this function converts the term representation into the internal representation mv_poly .*) -fun term2poly' (Const ("uminus",_) $ Free (str,_)) v = (*WN.7.3.03*) - if is_numeral str - then SOME [((the o int_of_str) ("-"^str), mk_monom "#" 0 v)] - else SOME [(~1, mk_monom str 1 v)] - - | term2poly' (Free(str,_)) v :mv_poly option = - let - val x=ref NONE; - val len=ref 0; - val vl=ref []; - val vh=ref []; - val i=ref 0; - in - if is_numeral str then - ( - SOME [(((the o int_of_str) str),mv_null2 v)] handle _ => NONE - ) - else (* variable *) - ( - len:=length v; - vh:= v; - while ((!len)>(!i)) do - ( - if str=hd((!vh)) then - ( - vl:=1::(!vl) - ) - else - ( - vl:=0::(!vl) - ); - vh:=tl(!vh); - i:=(!i)+1 - ); - SOME [(1,rev(!vl))] handle _ => NONE - ) - end - | term2poly' (Const ("op *",_) $ t1 $ t2) v :mv_poly option= - let - val t1pp=ref []; - val t2pp=ref []; - val t1c=ref 0; - val t2c=ref 0; - in - ( - t1pp:=(#2(hd(the(term2poly' t1 v)))); - t2pp:=(#2(hd(the(term2poly' t2 v)))); - t1c:=(#1(hd(the(term2poly' t1 v)))); - t2c:=(#1(hd(the(term2poly' t2 v)))); - - SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] - handle _ => NONE - - ) - end - | term2poly' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ - (t2 as Free (str2,_))) v :mv_poly option= - let - val x=ref NONE; - val len=ref 0; - val vl=ref []; - val vh=ref []; - val vtemp=ref []; - val i=ref 0; - in - ( - if (not o is_numeral) str1 andalso is_numeral str2 then - ( - len:=length(v); - vh:=v; - - while ((!len)>(!i)) do - ( - if str1=hd((!vh)) then - ( - vl:=((the o int_of_str) str2)::(!vl) - ) - else - ( - vl:=0::(!vl) - ); - vh:=tl(!vh); - i:=(!i)+1 - ); - SOME [(1,rev(!vl))] handle _ => NONE - ) - else raise error ("RATIONALS_TERM2POLY_EXCEPTION 1: Invalid term") - ) - end - | term2poly' (Const ("op +",_) $ t1 $ t2) v :mv_poly option = - ( - SOME ((the(term2poly' t1 v)) @ (the(term2poly' t2 v))) handle _ => NONE - ) - | term2poly' (Const ("op -",_) $ t1 $ t2) v :mv_poly option = - ( - SOME ((the(term2poly' t1 v)) @ mv_skalar_mul((the(term2poly' t2 v)),~1)) handle _ => NONE - ) - | term2poly' (term) v = raise error ("RATIONALS_TERM2POLY_EXCEPTION 2: Invalid term"); - -(*. translates an Isabelle term into internal representation. - term2poly - fn : term -> (*normalform [2] *) - string list -> (*for ...!!! BITTE DIE ERKLÄRUNG, - DIE DU MIR LETZTES MAL GEGEBEN HAST*) - mv_monom list (*internal representation *) - option (*the translation may fail with NONE*) -.*) -fun term2poly (t:term) v = - if is_polynomial t then term2poly' t v - else raise error ("term2poly: invalid = "^(term2str t)); - -(*. same as term2poly with automatic detection of the variables .*) -fun term2polyx t = term2poly t (((map free2str) o vars) t); - -(*. checks if the term is in expanded polynomial form and converts it into the internal representation .*) -fun expanded2poly (t:term) v = - (*if is_expanded t then*) term2poly' t v - (*else raise error ("RATIONALS_EXPANDED2POLY_EXCEPTION: Invalid Polynomial")*); - -(*. same as expanded2poly with automatic detection of the variables .*) -fun expanded2polyx t = expanded2poly t (((map free2str) o vars) t); - -(*. converts a powerproduct into term representation .*) -fun powerproduct2term(xs,v) = - let - val xss=ref xs; - val vv=ref v; - in - ( - while hd(!xss)=0 do - ( - xss:=tl(!xss); - vv:=tl(!vv) - ); - - if list_is_null(tl(!xss)) then - ( - if hd(!xss)=1 then Free(hd(!vv), HOLogic.realT) - else - ( - Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT) - ) - ) - else - ( - if hd(!xss)=1 then - ( - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - Free(hd(!vv), HOLogic.realT) $ - powerproduct2term(tl(!xss),tl(!vv)) - ) - else - ( - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - ( - Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT) - ) $ - powerproduct2term(tl(!xss),tl(!vv)) - ) - ) - ) - end; - -(*. converts a monom into term representation .*) -(*fun monom2term ((c,e):mv_monom, v:string list) = - if c=0 then Free(str_of_int 0,HOLogic.realT) - else - ( - if list_is_null(e) then - ( - Free(str_of_int c,HOLogic.realT) - ) - else - ( - if c=1 then - ( - powerproduct2term(e,v) - ) - else - ( - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - Free(str_of_int c,HOLogic.realT) $ - powerproduct2term(e,v) - ) - ) - );*) - - -(*fun monom2term ((i, is):mv_monom, v) = - if list_is_null is - then - if i >= 0 - then Free (str_of_int i, HOLogic.realT) - else Const ("uminus", HOLogic.realT --> HOLogic.realT) $ - Free ((str_of_int o abs) i, HOLogic.realT) - else - if i > 0 - then Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $ - (Free (str_of_int i, HOLogic.realT)) $ - powerproduct2term(is, v) - else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $ - (Const ("uminus", HOLogic.realT --> HOLogic.realT) $ - Free ((str_of_int o abs) i, HOLogic.realT)) $ - powerproduct2term(is, vs);---------------------------*) -fun monom2term ((i, is) : mv_monom, vs) = - if list_is_null is - then Free (str_of_int i, HOLogic.realT) - else if i = 1 - then powerproduct2term (is, vs) - else Const ("op *", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $ - (Free (str_of_int i, HOLogic.realT)) $ - powerproduct2term (is, vs); - -(*. converts the internal polynomial representation into an Isabelle term.*) -fun poly2term' ([] : mv_poly, vs) = Free(str_of_int 0, HOLogic.realT) - | poly2term' ([(c, e) : mv_monom], vs) = monom2term ((c, e), vs) - | poly2term' ((c, e) :: ces, vs) = - Const("op +", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $ - poly2term (ces, vs) $ monom2term ((c, e), vs) -and poly2term (xs, vs) = poly2term' (rev (sort (mv_geq LEX_) (xs)), vs); - - -(*. converts a monom into term representation .*) -(*. ignores the sign of the coefficients => use only for exp-poly functions .*) -fun monom2term2((c,e):mv_monom, v:string list) = - if c=0 then Free(str_of_int 0,HOLogic.realT) - else - ( - if list_is_null(e) then - ( - Free(str_of_int (abs(c)),HOLogic.realT) - ) - else - ( - if abs(c)=1 then - ( - powerproduct2term(e,v) - ) - else - ( - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - Free(str_of_int (abs(c)),HOLogic.realT) $ - powerproduct2term(e,v) - ) - ) - ); - -(*. converts the expanded polynomial representation into the term representation .*) -fun exp2term' ([]:mv_poly,vars) = Free(str_of_int 0,HOLogic.realT) - | exp2term' ([(c,e)],vars) = monom2term((c,e),vars) - | exp2term' ((c1,e1)::others,vars) = - if c1<0 then - Const("op -",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - exp2term'(others,vars) $ - ( - monom2term2((c1,e1),vars) - ) - else - Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - exp2term'(others,vars) $ - ( - monom2term2((c1,e1),vars) - ); - -(*. sorts the powerproduct by lexicographic termorder and converts them into - a term in polynomial representation .*) -fun poly2expanded (xs,vars) = exp2term'(rev(sort (mv_geq LEX_) (xs)),vars); - -(*. converts a polynomial into expanded form .*) -fun polynomial2expanded t = - (let - val vars=(((map free2str) o vars) t); - in - SOME (poly2expanded (the (term2poly t vars), vars)) - end) handle _ => NONE; - -(*. converts a polynomial into polynomial form .*) -fun expanded2polynomial t = - (let - val vars=(((map free2str) o vars) t); - in - SOME (poly2term (the (expanded2poly t vars), vars)) - end) handle _ => NONE; - - -(*. calculates the greatest common divisor of numerator and denominator and seperates it from each .*) -fun step_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) = - let - val p1' = ref []; - val p2' = ref []; - val p3 = ref [] - val vars = rev(get_vars(p1) union get_vars(p2)); - in - ( - p1':= sort (mv_geq LEX_) (the (term2poly p1 vars )); - p2':= sort (mv_geq LEX_) (the (term2poly p2 vars )); - p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); - if (!p3)=[(1,mv_null2(vars))] then - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2 - ) - else - ( - - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); - - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(!p1',vars) $ - poly2term(!p3,vars) - ) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(!p2',vars) $ - poly2term(!p3,vars) - ) - ) - else - ( - p1':=mv_skalar_mul(!p1',~1); - p2':=mv_skalar_mul(!p2',~1); - p3:=mv_skalar_mul(!p3,~1); - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(!p1',vars) $ - poly2term(!p3,vars) - ) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(!p2',vars) $ - poly2term(!p3,vars) - ) - ) - ) - ) - ) - end -| step_cancel _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction"); - - -(*. same as step_cancel, this time for expanded forms (input+output) .*) -fun step_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) = - let - val p1' = ref []; - val p2' = ref []; - val p3 = ref [] - val vars = rev(get_vars(p1) union get_vars(p2)); - in - ( - p1':= sort (mv_geq LEX_) (the (expanded2poly p1 vars )); - p2':= sort (mv_geq LEX_) (the (expanded2poly p2 vars )); - p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); - if (!p3)=[(1,mv_null2(vars))] then - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2 - ) - else - ( - - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); - - if #1(hd(sort (mv_geq LEX_) (!p2')))(* mv_lc2(!p2',LEX_)*)>0 then - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(!p1',vars) $ - poly2expanded(!p3,vars) - ) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(!p2',vars) $ - poly2expanded(!p3,vars) - ) - ) - else - ( - p1':=mv_skalar_mul(!p1',~1); - p2':=mv_skalar_mul(!p2',~1); - p3:=mv_skalar_mul(!p3,~1); - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(!p1',vars) $ - poly2expanded(!p3,vars) - ) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(!p2',vars) $ - poly2expanded(!p3,vars) - ) - ) - ) - ) - ) - end -| step_cancel_expanded _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction"); - -(*. calculates the greatest common divisor of numerator and denominator and divides each through it .*) -fun direct_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) = - let - val p1' = ref []; - val p2' = ref []; - val p3 = ref [] - val vars = rev(get_vars(p1) union get_vars(p2)); - in - ( - p1':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p1 vars )),LEX_)); - p2':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p2 vars )),LEX_)); - p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); - - if (!p3)=[(1,mv_null2(vars))] then - ( - (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[]) - ) - else - ( - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then - ( - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2term((!p1'),vars) - ) - $ - ( - poly2term((!p2'),vars) - ) - ) - , - if mv_grad(!p3)>0 then - [ - ( - Const ("Not",[bool]--->bool) $ - ( - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ - poly2term((!p3),vars) $ - Free("0",HOLogic.realT) - ) - ) - ] - else - [] - ) - else - ( - p1':=mv_skalar_mul(!p1',~1); - p2':=mv_skalar_mul(!p2',~1); - if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1); - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2term((!p1'),vars) - ) - $ - ( - poly2term((!p2'),vars) - ) - , - if mv_grad(!p3)>0 then - [ - ( - Const ("Not",[bool]--->bool) $ - ( - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ - poly2term((!p3),vars) $ - Free("0",HOLogic.realT) - ) - ) - ] - else - [] - ) - ) - ) - ) - end - | direct_cancel _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction"); - -(*. same es direct_cancel, this time for expanded forms (input+output).*) -fun direct_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) = - let - val p1' = ref []; - val p2' = ref []; - val p3 = ref [] - val vars = rev(get_vars(p1) union get_vars(p2)); - in - ( - p1':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p1 vars )),LEX_)); - p2':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p2 vars )),LEX_)); - p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); - - if (!p3)=[(1,mv_null2(vars))] then - ( - (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[]) - ) - else - ( - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then - ( - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2expanded((!p1'),vars) - ) - $ - ( - poly2expanded((!p2'),vars) - ) - ) - , - if mv_grad(!p3)>0 then - [ - ( - Const ("Not",[bool]--->bool) $ - ( - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ - poly2expanded((!p3),vars) $ - Free("0",HOLogic.realT) - ) - ) - ] - else - [] - ) - else - ( - p1':=mv_skalar_mul(!p1',~1); - p2':=mv_skalar_mul(!p2',~1); - if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1); - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2expanded((!p1'),vars) - ) - $ - ( - poly2expanded((!p2'),vars) - ) - , - if mv_grad(!p3)>0 then - [ - ( - Const ("Not",[bool]--->bool) $ - ( - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ - poly2expanded((!p3),vars) $ - Free("0",HOLogic.realT) - ) - ) - ] - else - [] - ) - ) - ) - ) - end - | direct_cancel_expanded _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction"); - - -(*. adds two fractions .*) -fun add_fract ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) = - let - val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22); - val t11'=ref (the(term2poly t11 vars)); -val _= writeln"### add_fract: done t11" - val t12'=ref (the(term2poly t12 vars)); -val _= writeln"### add_fract: done t12" - val t21'=ref (the(term2poly t21 vars)); -val _= writeln"### add_fract: done t21" - val t22'=ref (the(term2poly t22 vars)); -val _= writeln"### add_fract: done t22" - val den=ref []; - val nom=ref []; - val m1=ref []; - val m2=ref []; - in - - ( - den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22')); -writeln"### add_fract: done sort mv_lcm"; - m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_))); -writeln"### add_fract: done sort mv_division t12"; - m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_))); -writeln"### add_fract: done sort mv_division t22"; - nom :=sort (mv_geq LEX_) - (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_), - mv_mul(!t21',!m2,LEX_), - LEX_), - LEX_)); -writeln"### add_fract: done sort mv_add"; - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2term((!nom),vars) - ) - $ - ( - poly2term((!den),vars) - ) - ) - ) - end - | add_fract (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: Invalid add_fraction call"); - -(*. adds two expanded fractions .*) -fun add_fract_exp ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) = - let - val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22); - val t11'=ref (the(expanded2poly t11 vars)); - val t12'=ref (the(expanded2poly t12 vars)); - val t21'=ref (the(expanded2poly t21 vars)); - val t22'=ref (the(expanded2poly t22 vars)); - val den=ref []; - val nom=ref []; - val m1=ref []; - val m2=ref []; - in - - ( - den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22')); - m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_))); - m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_))); - nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_)); - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - poly2expanded((!nom),vars) - ) - $ - ( - poly2expanded((!den),vars) - ) - ) - ) - end - | add_fract_exp (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXP_EXCEPTION: Invalid add_fraction call"); - -(*. adds a list of terms .*) -fun add_list_of_fractions []= (Free("0",HOLogic.realT),[]) - | add_list_of_fractions [x]= direct_cancel x - | add_list_of_fractions (x::y::xs) = - let - val (t1a,rest1)=direct_cancel(x); -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(x)"; - val (t2a,rest2)=direct_cancel(y); -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(y)"; - val (t3a,rest3)=(add_list_of_fractions (add_fract(t1a,t2a)::xs)); -val _= writeln"### add_list_of_fractions xs: has done add_list_of_fraction xs"; - val (t4a,rest4)=direct_cancel(t3a); -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(t3a)"; - val rest=rest1 union rest2 union rest3 union rest4; - in - (writeln"### add_list_of_fractions in"; - ( - (t4a,rest) - ) - ) - end; - -(*. adds a list of expanded terms .*) -fun add_list_of_fractions_exp []= (Free("0",HOLogic.realT),[]) - | add_list_of_fractions_exp [x]= direct_cancel_expanded x - | add_list_of_fractions_exp (x::y::xs) = - let - val (t1a,rest1)=direct_cancel_expanded(x); - val (t2a,rest2)=direct_cancel_expanded(y); - val (t3a,rest3)=(add_list_of_fractions_exp (add_fract_exp(t1a,t2a)::xs)); - val (t4a,rest4)=direct_cancel_expanded(t3a); - val rest=rest1 union rest2 union rest3 union rest4; - in - ( - (t4a,rest) - ) - end; - -(*. calculates the lcm of a list of mv_poly .*) -fun calc_lcm ([x],var)= (x,var) - | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var); - -(*. converts a list of terms to a list of mv_poly .*) -fun t2d([],_)=[] - | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars); - -(*. same as t2d, this time for expanded forms .*) -fun t2d_exp([],_)=[] - | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars); - -(*. converts a list of fract terms to a list of their denominators .*) -fun termlist2denominators [] = ([],[]) - | termlist2denominators xs = - let - val xxs=ref xs; - val var=ref []; - in - var:=[]; - while length(!xxs)>0 do - ( - let - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); - in - ( - xxs:=tl(!xxs); - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) - ) - end - ); - (t2d(xs,!var),!var) - end; - -(*. calculates the lcm of a list of mv_poly .*) -fun calc_lcm ([x],var)= (x,var) - | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var); - -(*. converts a list of terms to a list of mv_poly .*) -fun t2d([],_)=[] - | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars); - -(*. same as t2d, this time for expanded forms .*) -fun t2d_exp([],_)=[] - | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars); - -(*. converts a list of fract terms to a list of their denominators .*) -fun termlist2denominators [] = ([],[]) - | termlist2denominators xs = - let - val xxs=ref xs; - val var=ref []; - in - var:=[]; - while length(!xxs)>0 do - ( - let - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); - in - ( - xxs:=tl(!xxs); - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) - ) - end - ); - (t2d(xs,!var),!var) - end; - -(*. same as termlist2denminators, this time for expanded forms .*) -fun termlist2denominators_exp [] = ([],[]) - | termlist2denominators_exp xs = - let - val xxs=ref xs; - val var=ref []; - in - var:=[]; - while length(!xxs)>0 do - ( - let - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); - in - ( - xxs:=tl(!xxs); - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) - ) - end - ); - (t2d_exp(xs,!var),!var) - end; - -(*. reduces all fractions to the least common denominator .*) -fun com_den(x::xs,denom,den,var)= - let - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; - val p2= sort (mv_geq LEX_) (the(term2poly p2' var)); - val p3= #1(mv_division(denom,p2,LEX_)); - val p1var=get_vars(p1'); - in - if length(xs)>0 then - if p3=[(1,mv_null2(var))] then - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - poly2term(the (term2poly p1' p1var),p1var) - $ - den - ) - $ - #1(com_den(xs,denom,den,var)) - , - [] - ) - else - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(the (term2poly p1' p1var),p1var) $ - poly2term(p3,var) - ) - $ - ( - den - ) - ) - $ - #1(com_den(xs,denom,den,var)) - , - [] - ) - else - if p3=[(1,mv_null2(var))] then - ( - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - poly2term(the (term2poly p1' p1var),p1var) - $ - den - ) - , - [] - ) - else - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(the (term2poly p1' p1var),p1var) $ - poly2term(p3,var) - ) - $ - den - , - [] - ) - end; - -(*. same as com_den, this time for expanded forms .*) -fun com_den_exp(x::xs,denom,den,var)= - let - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; - val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var)); - val p3= #1(mv_division(denom,p2,LEX_)); - val p1var=get_vars(p1'); - in - if length(xs)>0 then - if p3=[(1,mv_null2(var))] then - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - poly2expanded(the(expanded2poly p1' p1var),p1var) - $ - den - ) - $ - #1(com_den_exp(xs,denom,den,var)) - , - [] - ) - else - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(the(expanded2poly p1' p1var),p1var) $ - poly2expanded(p3,var) - ) - $ - ( - den - ) - ) - $ - #1(com_den_exp(xs,denom,den,var)) - , - [] - ) - else - if p3=[(1,mv_null2(var))] then - ( - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - poly2expanded(the(expanded2poly p1' p1var),p1var) - $ - den - ) - , - [] - ) - else - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) - $ - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(the(expanded2poly p1' p1var),p1var) $ - poly2expanded(p3,var) - ) - $ - den - , - [] - ) - end; - -(* wird aktuell nicht mehr gebraucht, bei rückänderung schon -------------------------------------------------------------- -(* WN0210???SK brauch ma des überhaupt *) -fun com_den2(x::xs,denom,den,var)= - let - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; - val p2= sort (mv_geq LEX_) (the(term2poly p2' var)); - val p3= #1(mv_division(denom,p2,LEX_)); - val p1var=get_vars(p1'); - in - if length(xs)>0 then - if p3=[(1,mv_null2(var))] then - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(the(term2poly p1' p1var),p1var) $ - com_den2(xs,denom,den,var) - ) - else - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - ( - let - val p3'=poly2term(p3,var); - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); - in - poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars) - end - ) $ - com_den2(xs,denom,den,var) - ) - else - if p3=[(1,mv_null2(var))] then - ( - poly2term(the(term2poly p1' p1var),p1var) - ) - else - ( - let - val p3'=poly2term(p3,var); - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); - in - poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars) - end - ) - end; - -(* WN0210???SK brauch ma des überhaupt *) -fun com_den_exp2(x::xs,denom,den,var)= - let - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; - val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var)); - val p3= #1(mv_division(denom,p2,LEX_)); - val p1var=get_vars p1'; - in - if length(xs)>0 then - if p3=[(1,mv_null2(var))] then - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(the (expanded2poly p1' p1var),p1var) $ - com_den_exp2(xs,denom,den,var) - ) - else - ( - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - ( - let - val p3'=poly2expanded(p3,var); - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); - in - poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars) - end - ) $ - com_den_exp2(xs,denom,den,var) - ) - else - if p3=[(1,mv_null2(var))] then - ( - poly2expanded(the (expanded2poly p1' p1var),p1var) - ) - else - ( - let - val p3'=poly2expanded(p3,var); - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); - in - poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars) - end - ) - end; ----------------------------------------------------------*) - - -(*. searches for an element y of a list ys, which has an gcd not 1 with x .*) -fun exists_gcd (x,[]) = false - | exists_gcd (x,y::ys) = if mv_gcd x y = [(1,mv_null2(#2(hd(x))))] then exists_gcd (x,ys) - else true; - -(*. divides each element of the list xs with y .*) -fun list_div ([],y) = [] - | list_div (x::xs,y) = - let - val (d,r)=mv_division(x,y,LEX_); - in - if r=[] then - d::list_div(xs,y) - else x::list_div(xs,y) - end; - -(*. checks if x is in the list ys .*) -fun in_list (x,[]) = false - | in_list (x,y::ys) = if x=y then true - else in_list(x,ys); - -(*. deletes all equal elements of the list xs .*) -fun kill_equal [] = [] - | kill_equal (x::xs) = if in_list(x,xs) orelse x=[(1,mv_null2(#2(hd(x))))] then kill_equal(xs) - else x::kill_equal(xs); - -(*. searches for new factors .*) -fun new_factors [] = [] - | new_factors (list:mv_poly list):mv_poly list = - let - val l = kill_equal list; - val len = length(l); - in - if len>=2 then - ( - let - val x::y::xs=l; - val gcd=mv_gcd x y; - in - if gcd=[(1,mv_null2(#2(hd(x))))] then - ( - if exists_gcd(x,xs) then new_factors (y::xs @ [x]) - else x::new_factors(y::xs) - ) - else gcd::new_factors(kill_equal(list_div(x::y::xs,gcd))) - end - ) - else - if len=1 then [hd(l)] - else [] - end; - -(*. gets the factors of a list .*) -fun get_factors x = new_factors x; - -(*. multiplies the elements of the list .*) -fun multi_list [] = [] - | multi_list (x::xs) = if xs=[] then x - else mv_mul(x,multi_list xs,LEX_); - -(*. makes a term out of the elements of the list (polynomial representation) .*) -fun make_term ([],vars) = Free(str_of_int 0,HOLogic.realT) - | make_term ((x::xs),vars) = if length(xs)=0 then poly2term(sort (mv_geq LEX_) (x),vars) - else - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2term(sort (mv_geq LEX_) (x),vars) $ - make_term(xs,vars) - ); - -(*. factorizes the denominator (polynomial representation) .*) -fun factorize_den (l,den,vars) = - let - val factor_list=kill_equal( (get_factors l)); - val mlist=multi_list(factor_list); - val (last,rest)=mv_division(den,multi_list(factor_list),LEX_); - in - if rest=[] then - ( - if last=[(1,mv_null2(vars))] then make_term(factor_list,vars) - else make_term(last::factor_list,vars) - ) - else raise error ("RATIONALS_FACTORIZE_DEN_EXCEPTION: Invalid factor by division") - end; - -(*. makes a term out of the elements of the list (expanded polynomial representation) .*) -fun make_exp ([],vars) = Free(str_of_int 0,HOLogic.realT) - | make_exp ((x::xs),vars) = if length(xs)=0 then poly2expanded(sort (mv_geq LEX_) (x),vars) - else - ( - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - poly2expanded(sort (mv_geq LEX_) (x),vars) $ - make_exp(xs,vars) - ); - -(*. factorizes the denominator (expanded polynomial representation) .*) -fun factorize_den_exp (l,den,vars) = - let - val factor_list=kill_equal( (get_factors l)); - val mlist=multi_list(factor_list); - val (last,rest)=mv_division(den,multi_list(factor_list),LEX_); - in - if rest=[] then - ( - if last=[(1,mv_null2(vars))] then make_exp(factor_list,vars) - else make_exp(last::factor_list,vars) - ) - else raise error ("RATIONALS_FACTORIZE_DEN_EXP_EXCEPTION: Invalid factor by division") - end; - -(*. calculates the common denominator of all elements of the list and multiplies .*) -(*. the nominators and denominators with the correct factor .*) -(*. (polynomial representation) .*) -fun step_add_list_of_fractions []=(Free("0",HOLogic.realT),[]:term list) - | step_add_list_of_fractions [x]= raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXCEPTION: Nothing to add") - | step_add_list_of_fractions (xs) = - let - val den_list=termlist2denominators (xs); (* list of denominators *) - val (denom,var)=calc_lcm(den_list); (* common denominator *) - val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) - in - com_den(xs,denom,den,var) - end; - -(*. calculates the common denominator of all elements of the list and multiplies .*) -(*. the nominators and denominators with the correct factor .*) -(*. (expanded polynomial representation) .*) -fun step_add_list_of_fractions_exp [] = (Free("0",HOLogic.realT),[]:term list) - | step_add_list_of_fractions_exp [x] = raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXP_EXCEPTION: Nothing to add") - | step_add_list_of_fractions_exp (xs)= - let - val den_list=termlist2denominators_exp (xs); (* list of denominators *) - val (denom,var)=calc_lcm(den_list); (* common denominator *) - val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) - in - com_den_exp(xs,denom,den,var) - end; - -(* wird aktuell nicht mehr gebraucht, bei rückänderung schon -------------------------------------------------------------- -(* WN0210???SK brauch ma des überhaupt *) -fun step_add_list_of_fractions2 []=(Free("0",HOLogic.realT),[]:term list) - | step_add_list_of_fractions2 [x]=(x,[]) - | step_add_list_of_fractions2 (xs) = - let - val den_list=termlist2denominators (xs); (* list of denominators *) - val (denom,var)=calc_lcm(den_list); (* common denominator *) - val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) - in - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - com_den2(xs,denom, poly2term(denom,var)(*den*),var) $ - poly2term(denom,var) - , - [] - ) - end; - -(* WN0210???SK brauch ma des überhaupt *) -fun step_add_list_of_fractions2_exp []=(Free("0",HOLogic.realT),[]:term list) - | step_add_list_of_fractions2_exp [x]=(x,[]) - | step_add_list_of_fractions2_exp (xs) = - let - val den_list=termlist2denominators_exp (xs); (* list of denominators *) - val (denom,var)=calc_lcm(den_list); (* common denominator *) - val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) - in - ( - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - com_den_exp2(xs,denom, poly2term(denom,var)(*den*),var) $ - poly2expanded(denom,var) - , - [] - ) - end; ----------------------------------------------- *) - - -(*. converts a term, which contains severel terms seperated by +, into a list of these terms .*) -fun term2list (t as (Const("HOL.divide",_) $ _ $ _)) = [t] - | term2list (t as (Const("Atools.pow",_) $ _ $ _)) = - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - t $ Free("1",HOLogic.realT) - ] - | term2list (t as (Free(_,_))) = - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - t $ Free("1",HOLogic.realT) - ] - | term2list (t as (Const("op *",_) $ _ $ _)) = - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ - t $ Free("1",HOLogic.realT) - ] - | term2list (Const("op +",_) $ t1 $ t2) = term2list(t1) @ term2list(t2) - | term2list (Const("op -",_) $ t1 $ t2) = - raise error ("RATIONALS_TERM2LIST_EXCEPTION: - not implemented yet") - | term2list _ = raise error ("RATIONALS_TERM2LIST_EXCEPTION: invalid term"); - -(*.factors out the gcd of nominator and denominator: - a/b = (a' * gcd)/(b' * gcd), a,b,gcd are poly[2].*) -fun factout_p_ (thy:theory) t = SOME (step_cancel t,[]:term list); -fun factout_ (thy:theory) t = SOME (step_cancel_expanded t,[]:term list); - -(*.cancels a single fraction with normalform [2] - resulting in a canceled fraction [2], see factout_ .*) -fun cancel_p_ (thy:theory) t = (*WN.2.6.03 no rewrite -> NONE !*) - (let val (t',asm) = direct_cancel(*_expanded ... corrected MG.21.8.03*) t - in if t = t' then NONE else SOME (t',asm) - end) handle _ => NONE; -(*.the same as above with normalform [3] - val cancel_ : - theory -> (*10.02 unused *) - term -> (*fraction in normalform [3] *) - (term * (*fraction in normalform [3] *) - term list) (*casual asumptions in normalform [3] *) - option (*NONE: the function is not applicable *).*) -fun cancel_ (thy:theory) t = SOME (direct_cancel_expanded t) handle _ => NONE; - -(*.transforms sums of at least 2 fractions [3] to - sums with the least common multiple as nominator.*) -fun common_nominator_p_ (thy:theory) t = -((*writeln("### common_nominator_p_ called");*) - SOME (step_add_list_of_fractions(term2list(t))) handle _ => NONE -); -fun common_nominator_ (thy:theory) t = - SOME (step_add_list_of_fractions_exp(term2list(t))) handle _ => NONE; - -(*.add 2 or more fractions -val add_fraction_p_ : - theory -> (*10.02 unused *) - term -> (*2 or more fractions with normalform [2] *) - (term * (*one fraction with normalform [2] *) - term list) (*casual assumptions in normalform [2] WN0210???SK *) - option (*NONE: the function is not applicable *).*) -fun add_fraction_p_ (thy:theory) t = -(writeln("### add_fraction_p_ called"); - (let val ts = term2list t - in if 1 < length ts - then SOME (add_list_of_fractions ts) - else NONE (*raise error ("RATIONALS_ADD_EXCEPTION: nothing to add")*) - end) handle _ => NONE -); -(*.same as add_fraction_p_ but with normalform [3].*) -(*SOME (step_add_list_of_fractions2(term2list(t))); *) -fun add_fraction_ (thy:theory) t = - if length(term2list(t))>1 - then SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE - else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*) - NONE; -fun add_fraction_ (thy:theory) t = - (if 1 < length (term2list t) - then SOME (add_list_of_fractions_exp (term2list t)) - else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*) - NONE) handle _ => NONE; - -(*SOME (step_add_list_of_fractions2_exp(term2list(t))); *) - -(*. brings the term into a normal form .*) -fun norm_rational_ (thy:theory) t = - SOME (add_list_of_fractions(term2list(t))) handle _ => NONE; -fun norm_expanded_rat_ (thy:theory) t = - SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE; - - -(*.evaluates conditions in calculate_Rational.*) -(*make local with FIXX@ME result:term *term list*) -val calc_rat_erls = prep_rls( - Rls {id = "calc_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [], *) - rules = - [Calc ("op =",eval_equal "#equal_"), - Calc ("Atools.is'_const",eval_const "#is_const_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false) - ], - scr = EmptyScr}); - - -(*.simplifies expressions with numerals; - does NOT rearrange the term by AC-rewriting; thus terms with variables - need to have constants to be commuted together respectively.*) -val calculate_Rational = prep_rls( - merge_rls "calculate_Rational" - (Rls {id = "divide", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = calc_rat_erls, srls = Erls, (*asm_thm = [],*) - calc = [], - rules = - [Calc ("HOL.divide" ,eval_cancel "#divide_"), - - Thm ("sym_real_minus_divide_eq", - num_str (real_minus_divide_eq RS sym)), - (*SYM - ?x / ?y = - (?x / ?y) may come from subst*) - - Thm ("rat_add",num_str rat_add), - (*"[| a is_const; b is_const; c is_const; d is_const |] ==> \ - \"a / c + b / d = (a * d) / (c * d) + (b * c ) / (d * c)"*) - Thm ("rat_add1",num_str rat_add1), - (*"[| a is_const; b is_const; c is_const |] ==> \ - \"a / c + b / c = (a + b) / c"*) - Thm ("rat_add2",num_str rat_add2), - (*"[| ?a is_const; ?b is_const; ?c is_const |] ==> \ - \?a / ?c + ?b = (?a + ?b * ?c) / ?c"*) - Thm ("rat_add3",num_str rat_add3), - (*"[| a is_const; b is_const; c is_const |] ==> \ - \"a + b / c = (a * c) / c + b / c"\ - \.... is_const to be omitted here FIXME*) - - Thm ("rat_mult",num_str rat_mult), - (*a / b * (c / d) = a * c / (b * d)*) - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), - (*?x * (?y / ?z) = ?x * ?y / ?z*) - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), - (*?y / ?z * ?x = ?y * ?x / ?z*) - - Thm ("real_divide_divide1",num_str real_divide_divide1), - (*"?y ~= 0 ==> ?u / ?v / (?y / ?z) = ?u / ?v * (?z / ?y)"*) - Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq), - (*"?x / ?y / ?z = ?x / (?y * ?z)"*) - - Thm ("rat_power", num_str rat_power), - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) - - Thm ("mult_cross",num_str mult_cross), - (*"[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)*) - Thm ("mult_cross1",num_str mult_cross1), - (*" b ~= 0 ==> (a / b = c ) = (a = b * c)*) - Thm ("mult_cross2",num_str mult_cross2) - (*" d ~= 0 ==> (a = c / d) = (a * d = c)*) - ], scr = EmptyScr}) - calculate_Poly); - - -(*("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))*) -fun eval_is_expanded (thmid:string) _ - (t as (Const("Rational.is'_expanded", _) $ arg)) thy = - if is_expanded arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.true_const))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.false_const))) - | eval_is_expanded _ _ _ _ = NONE; - -val rational_erls = - merge_rls "rational_erls" calculate_Rational - (append_rls "is_expanded" Atools_erls - [Calc ("Rational.is'_expanded", eval_is_expanded "") - ]); - - - -(*.3 'reverse-rewrite-sets' for symbolic computation on rationals: - ================================================================= - A[2] 'cancel_p': . - A[3] 'cancel': . - B[2] 'common_nominator_p': transforms summands in a term [2] - to fractions with the (least) common multiple as nominator. - B[3] 'norm_rational': normalizes arbitrary algebraic terms (without - radicals and transzendental functions) to one canceled fraction, - nominator and denominator in polynomial form. - -In order to meet isac's requirements for interactive and stepwise calculation, -each 'reverse-rewerite-set' consists of an initialization for the interpreter -state and of 4 functions, each of which employs rewriting as much as possible. -The signature of these functions are the same in each 'reverse-rewrite-set' -respectively.*) - -(* ************************************************************************* *) - - -local(*. cancel_p ------------------------- -cancels a single fraction consisting of two (uni- or multivariate) -polynomials WN0609???SK[2] into another such a fraction; examples: - - a^2 + -1*b^2 a + b - -------------------- = --------- - a^2 + -2*a*b + b^2 a + -1*b - - a^2 a - --- = --- - a 1 - -Remark: the reverse ruleset does _NOT_ work properly with other input !.*) -(*WN020824 wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*) - -val {rules, rew_ord=(_,ro),...} = - rep_rls (assoc_rls "make_polynomial"); -(*WN060829 ... make_deriv does not terminate with 1st expl above, - see rational.sml --- investigate rulesets for cancel_p ---*) -val {rules, rew_ord=(_,ro),...} = - rep_rls (assoc_rls "rev_rew_p"); - -val thy = Rational.thy; - -(*.init_state = fn : term -> istate -initialzies the state of the script interpreter. The state is: - -type rrlsstate = (*state for reverse rewriting*) - (term * (*the current formula*) - term * (*the final term*) - rule list (*'reverse rule list' (#)*) - list * (*may be serveral, eg. in norm_rational*) - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) - (term * (*... rewrite with ...*) - term list)) (*... assumptions*) - list); (*derivation from given term to normalform - in reverse order with sym_thm; - (#) could be extracted from here by (map #1)*).*) -(* val {rules, rew_ord=(_,ro),...} = - rep_rls (assoc_rls "rev_rew_p") (*USE ALWAYS, SEE val cancel_p*); - val (thy, eval_rls, ro) =(Rational.thy, Atools_erls, ro) (*..val cancel_p*); - val t = t; - *) -fun init_state thy eval_rls ro t = - let val SOME (t',_) = factout_p_ thy t - val SOME (t'',asm) = cancel_p_ thy t - val der = reverse_deriv thy eval_rls rules ro NONE t' - val der = der @ [(Thm ("real_mult_div_cancel2", - num_str real_mult_div_cancel2), - (t'',asm))] - val rs = (distinct_Thm o (map #1)) der - val rs = filter_out (eq_Thms ["sym_real_add_zero_left", - "sym_real_mult_0", - "sym_real_mult_1" - (*..insufficient,eg.make_Polynomial*)])rs - in (t,t'',[rs(*here only _ONE_ to ease locate_rule*)],der) end; - -(*.locate_rule = fn : rule list -> term -> rule - -> (rule * (term * term list) option) list. - checks a rule R for being a cancel-rule, and if it is, - then return the list of rules (+ the terms they are rewriting to) - which need to be applied before R should be applied. - precondition: the rule is applicable to the argument-term. -arguments: - rule list: the reverse rule list - -> term : ... to which the rule shall be applied - -> rule : ... to be applied to term -value: - -> (rule : a rule rewriting to ... - * (term : ... the resulting term ... - * term list): ... with the assumptions ( //#0). - ) list : there may be several such rules; - the list is empty, if the rule has nothing to do - with cancelation.*) -(* val () = (); - *) -fun locate_rule thy eval_rls ro [rs] t r = - if (id_of_thm r) mem (map (id_of_thm)) rs - then let val ropt = - rewrite_ thy ro eval_rls true (thm_of_thm r) t; - in case ropt of - SOME ta => [(r, ta)] - | NONE => (writeln("### locate_rule: rewrite "^ - (id_of_thm r)^" "^(term2str t)^" = NONE"); - []) end - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) - | locate_rule _ _ _ _ _ _ = - raise error ("locate_rule: doesnt match rev-sets in istate"); - -(*.next_rule = fn : rule list -> term -> rule option - for a given term return the next rules to be done for cancelling. -arguments: - rule list : the reverse rule list - term : the term for which ... -value: - -> rule option: ... this rule is appropriate for cancellation; - there may be no such rule (if the term is canceled already.*) -(* val thy = Rational.thy; - val Rrls {rew_ord=(_,ro),...} = cancel; - val ([rs],t) = (rss,f); - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) - - val (thy, [rs]) = (Rational.thy, revsets); - val Rrls {rew_ord=(_,ro),...} = cancel; - nex [rs] t; - *) -fun next_rule thy eval_rls ro [rs] t = - let val der = make_deriv thy eval_rls rs ro NONE t; - in case der of -(* val (_,r,_)::_ = der; - *) - (_,r,_)::_ => SOME r - | _ => NONE - end - | next_rule _ _ _ _ _ = - raise error ("next_rule: doesnt match rev-sets in istate"); - -(*.val attach_form = f : rule list -> term -> term - -> (rule * (term * term list)) list - checks an input term TI, if it may belong to a current cancellation, by - trying to derive it from the given term TG. -arguments: - term : TG, the last one in the cancellation agreed upon by user + math-eng - -> term: TI, the next one input by the user -value: - -> (rule : the rule to be applied in order to reach TI - * (term : ... obtained by applying the rule ... - * term list): ... and the respective assumptions. - ) list : there may be several such rules; - the list is empty, if the users term does not belong - to a cancellation of the term last agreed upon.*) -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; - -in - -val cancel_p = - Rrls {id = "cancel_p", prepat=[], - rew_ord=("ord_make_polynomial", - ord_make_polynomial false Rational.thy), - erls = rational_erls, - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - (*asm_thm=[("real_mult_div_cancel2","")],*) - scr=Rfuns {init_state = init_state thy Atools_erls ro, - normal_form = cancel_p_ thy, - locate_rule = locate_rule thy Atools_erls ro, - next_rule = next_rule thy Atools_erls ro, - attach_form = attach_form}} -end;(*local*) - - -local(*.ad (1) 'cancel' ------------------------------- -cancels a single fraction consisting of two (uni- or multivariate) -polynomials WN0609???SK[3] into another such a fraction; examples: - - a^2 - b^2 a + b - -------------------- = --------- - a^2 - 2*a*b + b^2 a - *b - -Remark: the reverse ruleset does _NOT_ work properly with other input !.*) -(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*) - -(* -val SOME (Rls {rules=rules,rew_ord=(_,ro),...}) = - assoc'(!ruleset',"expand_binoms"); -*) -val {rules=rules,rew_ord=(_,ro),...} = - rep_rls (assoc_rls "expand_binoms"); -val thy = Rational.thy; - -fun init_state thy eval_rls ro t = - let val SOME (t',_) = factout_ thy t; - val SOME (t'',asm) = cancel_ thy t; - val der = reverse_deriv thy eval_rls rules ro NONE t'; - val der = der @ [(Thm ("real_mult_div_cancel2", - num_str real_mult_div_cancel2), - (t'',asm))] - val rs = map #1 der; - in (t,t'',[rs],der) end; - -fun locate_rule thy eval_rls ro [rs] t r = - if (id_of_thm r) mem (map (id_of_thm)) rs - then let val ropt = - rewrite_ thy ro eval_rls true (thm_of_thm r) t; - in case ropt of - SOME ta => [(r, ta)] - | NONE => (writeln("### locate_rule: rewrite "^ - (id_of_thm r)^" "^(term2str t)^" = NONE"); - []) end - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) - | locate_rule _ _ _ _ _ _ = - raise error ("locate_rule: doesnt match rev-sets in istate"); - -fun next_rule thy eval_rls ro [rs] t = - let val der = make_deriv thy eval_rls rs ro NONE t; - in case der of -(* val (_,r,_)::_ = der; - *) - (_,r,_)::_ => SOME r - | _ => NONE - end - | next_rule _ _ _ _ _ = - raise error ("next_rule: doesnt match rev-sets in istate"); - -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; - -val pat = (term_of o the o (parse thy)) "?r/?s"; -val pre1 = (term_of o the o (parse thy)) "?r is_expanded"; -val pre2 = (term_of o the o (parse thy)) "?s is_expanded"; -val prepat = [([pre1, pre2], pat)]; - -in - - -val cancel = - Rrls {id = "cancel", prepat=prepat, - rew_ord=("ord_make_polynomial", - ord_make_polynomial false Rational.thy), - erls = rational_erls, - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - scr=Rfuns {init_state = init_state thy Atools_erls ro, - normal_form = cancel_ thy, - locate_rule = locate_rule thy Atools_erls ro, - next_rule = next_rule thy Atools_erls ro, - attach_form = attach_form}} -end;(*local*) - - - -local(*.ad [2] 'common_nominator_p' ---------------------------------- -FIXME Beschreibung .*) - - -val {rules=rules,rew_ord=(_,ro),...} = - rep_rls (assoc_rls "make_polynomial"); -(*WN060829 ... make_deriv does not terminate with 1st expl above, - see rational.sml --- investigate rulesets for cancel_p ---*) -val {rules, rew_ord=(_,ro),...} = - rep_rls (assoc_rls "rev_rew_p"); -val thy = Rational.thy; - - -(*.common_nominator_p_ = fn : theory -> term -> (term * term list) option - as defined above*) - -(*.init_state = fn : term -> istate -initialzies the state of the interactive interpreter. The state is: - -type rrlsstate = (*state for reverse rewriting*) - (term * (*the current formula*) - term * (*the final term*) - rule list (*'reverse rule list' (#)*) - list * (*may be serveral, eg. in norm_rational*) - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) - (term * (*... rewrite with ...*) - term list)) (*... assumptions*) - list); (*derivation from given term to normalform - in reverse order with sym_thm; - (#) could be extracted from here by (map #1)*).*) -fun init_state thy eval_rls ro t = - let val SOME (t',_) = common_nominator_p_ thy t; - val SOME (t'',asm) = add_fraction_p_ thy t; - val der = reverse_deriv thy eval_rls rules ro NONE t'; - val der = der @ [(Thm ("real_mult_div_cancel2", - num_str real_mult_div_cancel2), - (t'',asm))] - val rs = (distinct_Thm o (map #1)) der; - val rs = filter_out (eq_Thms ["sym_real_add_zero_left", - "sym_real_mult_0", - "sym_real_mult_1"]) rs; - in (t,t'',[rs(*here only _ONE_*)],der) end; - -(* use"knowledge/Rational.ML"; - *) - -(*.locate_rule = fn : rule list -> term -> rule - -> (rule * (term * term list) option) list. - checks a rule R for being a cancel-rule, and if it is, - then return the list of rules (+ the terms they are rewriting to) - which need to be applied before R should be applied. - precondition: the rule is applicable to the argument-term. -arguments: - rule list: the reverse rule list - -> term : ... to which the rule shall be applied - -> rule : ... to be applied to term -value: - -> (rule : a rule rewriting to ... - * (term : ... the resulting term ... - * term list): ... with the assumptions ( //#0). - ) list : there may be several such rules; - the list is empty, if the rule has nothing to do - with cancelation.*) -(* val () = (); - *) -fun locate_rule thy eval_rls ro [rs] t r = - if (id_of_thm r) mem (map (id_of_thm)) rs - then let val ropt = - rewrite_ thy ro eval_rls true (thm_of_thm r) t; - in case ropt of - SOME ta => [(r, ta)] - | NONE => (writeln("### locate_rule: rewrite "^ - (id_of_thm r)^" "^(term2str t)^" = NONE"); - []) end - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) - | locate_rule _ _ _ _ _ _ = - raise error ("locate_rule: doesnt match rev-sets in istate"); - -(*.next_rule = fn : rule list -> term -> rule option - for a given term return the next rules to be done for cancelling. -arguments: - rule list : the reverse rule list - term : the term for which ... -value: - -> rule option: ... this rule is appropriate for cancellation; - there may be no such rule (if the term is canceled already.*) -(* val thy = Rational.thy; - val Rrls {rew_ord=(_,ro),...} = cancel; - val ([rs],t) = (rss,f); - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) - - val (thy, [rs]) = (Rational.thy, revsets); - val Rrls {rew_ord=(_,ro),...} = cancel; - nex [rs] t; - *) -fun next_rule thy eval_rls ro [rs] t = - let val der = make_deriv thy eval_rls rs ro NONE t; - in case der of -(* val (_,r,_)::_ = der; - *) - (_,r,_)::_ => SOME r - | _ => NONE - end - | next_rule _ _ _ _ _ = - raise error ("next_rule: doesnt match rev-sets in istate"); - -(*.val attach_form = f : rule list -> term -> term - -> (rule * (term * term list)) list - checks an input term TI, if it may belong to a current cancellation, by - trying to derive it from the given term TG. -arguments: - term : TG, the last one in the cancellation agreed upon by user + math-eng - -> term: TI, the next one input by the user -value: - -> (rule : the rule to be applied in order to reach TI - * (term : ... obtained by applying the rule ... - * term list): ... and the respective assumptions. - ) list : there may be several such rules; - the list is empty, if the users term does not belong - to a cancellation of the term last agreed upon.*) -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; - -val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v"; -val pat1 = (term_of o the o (parse thy)) "?r/?s+?u "; -val pat2 = (term_of o the o (parse thy)) "?r +?u/?v"; -val prepat = [([HOLogic.true_const], pat0), - ([HOLogic.true_const], pat1), - ([HOLogic.true_const], pat2)]; - -in - -(*11.02 schnelle L"osung f"ur RL: Bruch auch gek"urzt; - besser w"are: auf 1 gemeinsamen Bruchstrich, Nenner und Z"ahler unvereinfacht - dh. wie common_nominator_p_, aber auf 1 Bruchstrich*) -val common_nominator_p = - Rrls {id = "common_nominator_p", prepat=prepat, - rew_ord=("ord_make_polynomial", - ord_make_polynomial false Rational.thy), - erls = rational_erls, - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - scr=Rfuns {init_state = init_state thy Atools_erls ro, - normal_form = add_fraction_p_ thy,(*FIXME.WN0211*) - locate_rule = locate_rule thy Atools_erls ro, - next_rule = next_rule thy Atools_erls ro, - attach_form = attach_form}} -end;(*local*) - - -local(*.ad [2] 'common_nominator' ---------------------------------- -FIXME Beschreibung .*) - - -val {rules=rules,rew_ord=(_,ro),...} = - rep_rls (assoc_rls "make_polynomial"); -val thy = Rational.thy; - - -(*.common_nominator_ = fn : theory -> term -> (term * term list) option - as defined above*) - -(*.init_state = fn : term -> istate -initialzies the state of the interactive interpreter. The state is: - -type rrlsstate = (*state for reverse rewriting*) - (term * (*the current formula*) - term * (*the final term*) - rule list (*'reverse rule list' (#)*) - list * (*may be serveral, eg. in norm_rational*) - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) - (term * (*... rewrite with ...*) - term list)) (*... assumptions*) - list); (*derivation from given term to normalform - in reverse order with sym_thm; - (#) could be extracted from here by (map #1)*).*) -fun init_state thy eval_rls ro t = - let val SOME (t',_) = common_nominator_ thy t; - val SOME (t'',asm) = add_fraction_ thy t; - val der = reverse_deriv thy eval_rls rules ro NONE t'; - val der = der @ [(Thm ("real_mult_div_cancel2", - num_str real_mult_div_cancel2), - (t'',asm))] - val rs = (distinct_Thm o (map #1)) der; - val rs = filter_out (eq_Thms ["sym_real_add_zero_left", - "sym_real_mult_0", - "sym_real_mult_1"]) rs; - in (t,t'',[rs(*here only _ONE_*)],der) end; - -(* use"knowledge/Rational.ML"; - *) - -(*.locate_rule = fn : rule list -> term -> rule - -> (rule * (term * term list) option) list. - checks a rule R for being a cancel-rule, and if it is, - then return the list of rules (+ the terms they are rewriting to) - which need to be applied before R should be applied. - precondition: the rule is applicable to the argument-term. -arguments: - rule list: the reverse rule list - -> term : ... to which the rule shall be applied - -> rule : ... to be applied to term -value: - -> (rule : a rule rewriting to ... - * (term : ... the resulting term ... - * term list): ... with the assumptions ( //#0). - ) list : there may be several such rules; - the list is empty, if the rule has nothing to do - with cancelation.*) -(* val () = (); - *) -fun locate_rule thy eval_rls ro [rs] t r = - if (id_of_thm r) mem (map (id_of_thm)) rs - then let val ropt = - rewrite_ thy ro eval_rls true (thm_of_thm r) t; - in case ropt of - SOME ta => [(r, ta)] - | NONE => (writeln("### locate_rule: rewrite "^ - (id_of_thm r)^" "^(term2str t)^" = NONE"); - []) end - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) - | locate_rule _ _ _ _ _ _ = - raise error ("locate_rule: doesnt match rev-sets in istate"); - -(*.next_rule = fn : rule list -> term -> rule option - for a given term return the next rules to be done for cancelling. -arguments: - rule list : the reverse rule list - term : the term for which ... -value: - -> rule option: ... this rule is appropriate for cancellation; - there may be no such rule (if the term is canceled already.*) -(* val thy = Rational.thy; - val Rrls {rew_ord=(_,ro),...} = cancel; - val ([rs],t) = (rss,f); - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) - - val (thy, [rs]) = (Rational.thy, revsets); - val Rrls {rew_ord=(_,ro),...} = cancel_p; - nex [rs] t; - *) -fun next_rule thy eval_rls ro [rs] t = - let val der = make_deriv thy eval_rls rs ro NONE t; - in case der of -(* val (_,r,_)::_ = der; - *) - (_,r,_)::_ => SOME r - | _ => NONE - end - | next_rule _ _ _ _ _ = - raise error ("next_rule: doesnt match rev-sets in istate"); - -(*.val attach_form = f : rule list -> term -> term - -> (rule * (term * term list)) list - checks an input term TI, if it may belong to a current cancellation, by - trying to derive it from the given term TG. -arguments: - term : TG, the last one in the cancellation agreed upon by user + math-eng - -> term: TI, the next one input by the user -value: - -> (rule : the rule to be applied in order to reach TI - * (term : ... obtained by applying the rule ... - * term list): ... and the respective assumptions. - ) list : there may be several such rules; - the list is empty, if the users term does not belong - to a cancellation of the term last agreed upon.*) -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) - []:(rule * (term * term list)) list; - -val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v"; -val pat01 = (term_of o the o (parse thy)) "?r/?s-?u/?v"; -val pat1 = (term_of o the o (parse thy)) "?r/?s+?u "; -val pat11 = (term_of o the o (parse thy)) "?r/?s-?u "; -val pat2 = (term_of o the o (parse thy)) "?r +?u/?v"; -val pat21 = (term_of o the o (parse thy)) "?r -?u/?v"; -val prepat = [([HOLogic.true_const], pat0), - ([HOLogic.true_const], pat01), - ([HOLogic.true_const], pat1), - ([HOLogic.true_const], pat11), - ([HOLogic.true_const], pat2), - ([HOLogic.true_const], pat21)]; - - -in - -val common_nominator = - Rrls {id = "common_nominator", prepat=prepat, - rew_ord=("ord_make_polynomial", - ord_make_polynomial false Rational.thy), - erls = rational_erls, - calc = [("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], - (*asm_thm=[("real_mult_div_cancel2","")],*) - scr=Rfuns {init_state = init_state thy Atools_erls ro, - normal_form = add_fraction_ (*NOT common_nominator_*) thy, - locate_rule = locate_rule thy Atools_erls ro, - next_rule = next_rule thy Atools_erls ro, - attach_form = attach_form}} - -end;(*local*) - - -(*##*) -end;(*struct*) - -open RationalI; -(*##*) - -(*.the expression contains + - * ^ / only ?.*) -fun is_ratpolyexp (Free _) = true - | is_ratpolyexp (Const ("op +",_) $ Free _ $ Free _) = true - | is_ratpolyexp (Const ("op -",_) $ Free _ $ Free _) = true - | is_ratpolyexp (Const ("op *",_) $ Free _ $ Free _) = true - | is_ratpolyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true - | is_ratpolyexp (Const ("HOL.divide",_) $ Free _ $ Free _) = true - | is_ratpolyexp (Const ("op +",_) $ t1 $ t2) = - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) - | is_ratpolyexp (Const ("op -",_) $ t1 $ t2) = - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) - | is_ratpolyexp (Const ("op *",_) $ t1 $ t2) = - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) - | is_ratpolyexp (Const ("Atools.pow",_) $ t1 $ t2) = - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) - | is_ratpolyexp (Const ("HOL.divide",_) $ t1 $ t2) = - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) - | is_ratpolyexp _ = false; - -(*("is_ratpolyexp", ("Rational.is'_ratpolyexp", eval_is_ratpolyexp ""))*) -fun eval_is_ratpolyexp (thmid:string) _ - (t as (Const("Rational.is'_ratpolyexp", _) $ arg)) thy = - if is_ratpolyexp arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.true_const))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, HOLogic.false_const))) - | eval_is_ratpolyexp _ _ _ _ = NONE; - - - -(*-------------------18.3.03 --> struct <-----------vvv--*) -val add_fractions_p = common_nominator_p; (*FIXXXME:eilig f"ur norm_Rational*) - -(*.discard binary minus, shift unary minus into -1*; - unary minus before numerals are put into the numeral by parsing; - contains absolute minimum of thms for context in norm_Rational .*) -val discard_minus = prep_rls( - Rls {id = "discard_minus", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("real_diff_minus", num_str real_diff_minus), - (*"a - b = a + -1 * b"*) - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) - (*- ?z = "-1 * ?z"*) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }):rls; -(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*) -val powers_erls = prep_rls( - Rls {id = "powers_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"), - Calc ("Atools.is'_even",eval_is_even "#is_even_"), - Calc ("op <",eval_equ "#less_"), - Thm ("not_false", not_false), - Thm ("not_true", not_true), - Calc ("op +",eval_binop "#add_") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -(*.all powers over + distributed; atoms over * collected, other distributed - contains absolute minimum of thms for context in norm_Rational .*) -val powers = prep_rls( - Rls {id = "powers", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = powers_erls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("realpow_multI", num_str realpow_multI), - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) - Thm ("realpow_pow",num_str realpow_pow), - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) - Thm ("realpow_oneI",num_str realpow_oneI), - (*"r ^^^ 1 = r"*) - Thm ("realpow_minus_even",num_str realpow_minus_even), - (*"n is_even ==> (- r) ^^^ n = r ^^^ n" ?-->discard_minus?*) - Thm ("realpow_minus_odd",num_str realpow_minus_odd), - (*"Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"*) - - (*----- collect atoms over * -----*) - Thm ("realpow_two_atom",num_str realpow_two_atom), - (*"r is_atom ==> r * r = r ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r is_atom ==> r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("realpow_addI_atom",num_str realpow_addI_atom), - (*"r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) - - (*----- distribute none-atoms -----*) - Thm ("realpow_def_atom",num_str realpow_def_atom), - (*"[| 1 < n; not(r is_atom) |]==>r ^^^ n = r * r ^^^ (n + -1)"*) - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI), - (*"1 ^^^ n = 1"*) - Calc ("op +",eval_binop "#add_") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -(*.contains absolute minimum of thms for context in norm_Rational.*) -val rat_mult_divide = prep_rls( - Rls {id = "rat_mult_divide", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Thm ("rat_mult",num_str rat_mult), - (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), - (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2], - otherwise inv.to a / b / c = ...*) - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), - (*"?a / ?b * ?c = ?a * ?c / ?b" order weights x^^^n too much - and does not commute a / b * c ^^^ 2 !*) - - Thm ("real_divide_divide1_eq", real_divide_divide1_eq), - (*"?x / (?y / ?z) = ?x * ?z / ?y"*) - Thm ("real_divide_divide2_eq", real_divide_divide2_eq), - (*"?x / ?y / ?z = ?x / (?y * ?z)"*) - Calc ("HOL.divide" ,eval_cancel "#divide_") - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(*.contains absolute minimum of thms for context in norm_Rational.*) -val reduce_0_1_2 = prep_rls( - Rls{id = "reduce_0_1_2", preconds = [], rew_ord = ("dummy_ord", dummy_ord), - erls = e_rls,srls = Erls,calc = [],(*asm_thm = [],*) - rules = [(*Thm ("real_divide_1",num_str real_divide_1), - "?x / 1 = ?x" unnecess.for normalform*) - Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - (*Thm ("real_mult_minus1",num_str real_mult_minus1), - "-1 * z = - z"*) - (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel), - "- ?x * - ?y = ?x * ?y"*) - - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - (*Thm ("real_add_minus",num_str real_add_minus), - "?z + - ?z = 0"*) - - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_0_divide",num_str real_0_divide) - (*"0 / ?x = 0"*) - ], scr = EmptyScr}:rls); - -(*erls for calculate_Rational; - make local with FIXX@ME result:term *term list WN0609???SKMG*) -val norm_rat_erls = prep_rls( - Rls {id = "norm_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [Calc ("Atools.is'_const",eval_const "#is_const_") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -(*.consists of rls containing the absolute minimum of thms.*) -(*040209: this version has been used by RL for his equations, -which is now replaced by MGs version below -vvv OLD VERSION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*) -val norm_Rational = prep_rls( - Rls {id = "norm_Rational", preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [(*sequence given by operator precedence*) - Rls_ discard_minus, - Rls_ powers, - Rls_ rat_mult_divide, - Rls_ expand, - Rls_ reduce_0_1_2, - (*^^^^^^^^^ from RL -- not the latest one vvvvvvvvv*) - Rls_ order_add_mult, - Rls_ collect_numerals, - Rls_ add_fractions_p, - Rls_ cancel_p - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls); -val norm_Rational_parenthesized = prep_rls( - Seq {id = "norm_Rational_parenthesized", preconds = []:term list, - rew_ord = ("dummy_ord", dummy_ord), - erls = Atools_erls, srls = Erls, - calc = [], (*asm_thm = [],*) - rules = [Rls_ norm_Rational, (*from RL -- not the latest one*) - Rls_ discard_parentheses - ], - scr = EmptyScr - }:rls); - - -(*-------------------18.3.03 --> struct <-----------^^^--*) - - - -theory' := overwritel (!theory', [("Rational.thy",Rational.thy)]); - - -(*WN030318???SK: simplifies all but cancel and common_nominator*) -val simplify_rational = - merge_rls "simplify_rational" expand_binoms - (append_rls "divide" calculate_Rational - [Thm ("real_divide_1",num_str real_divide_1), - (*"?x / 1 = ?x"*) - Thm ("rat_mult",num_str rat_mult), - (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), - (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2], - otherwise inv.to a / b / c = ...*) - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), - (*"?a / ?b * ?c = ?a * ?c / ?b"*) - Thm ("add_minus",num_str add_minus), - (*"?a + ?b - ?b = ?a"*) - Thm ("add_minus1",num_str add_minus1), - (*"?a - ?b + ?b = ?a"*) - Thm ("real_divide_minus1",num_str real_divide_minus1) - (*"?x / -1 = - ?x"*) -(* -, - Thm ("",num_str ) -*) - ]); - -(*---------vvv-------------MG ab 1.07.2003--------------vvv-----------*) - -(* ------------------------------------------------------------------ *) -(* Simplifier für beliebige Buchterme *) -(* ------------------------------------------------------------------ *) -(*----------------------- norm_Rational_mg ---------------------------*) -(*. description of the simplifier see MG-DA.p.56ff .*) -(* ------------------------------------------------------------------- *) -val common_nominator_p_rls = prep_rls( - Rls {id = "common_nominator_p_rls", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], - rules = - [Rls_ common_nominator_p - (*FIXME.WN0401 ? redesign Rrls - use exhaustively on a term ? - FIXME.WN0510 unnecessary nesting: introduce RRls_ : rls -> rule*) - ], - scr = EmptyScr}); -(* ------------------------------------------------------------------- *) -val cancel_p_rls = prep_rls( - Rls {id = "cancel_p_rls", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], - rules = - [Rls_ cancel_p - (*FIXME.WN.0401 ? redesign Rrls - use exhaustively on a term ?*) - ], - scr = EmptyScr}); -(* -------------------------------------------------------------------- *) -(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions; - used in initial part norm_Rational_mg, see example DA-M02-main.p.60.*) -val rat_mult_poly = prep_rls( - Rls {id = "rat_mult_poly", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = append_rls "e_rls-is_polyexp" e_rls - [Calc ("Poly.is'_polyexp", eval_is_polyexp "")], - srls = Erls, calc = [], - rules = - [Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r) - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) - ], - scr = EmptyScr}); -(* ------------------------------------------------------------------ *) -(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions; - used in looping part norm_Rational_rls, see example DA-M02-main.p.60 - .. WHERE THE LATTER DOES ALWAYS WORK, BECAUSE erls = e_rls, - I.E. THE RESPECTIVE ASSUMPTION IS STORED AND Thm APPLIED; WN051028 - ... WN0609???MG.*) -val rat_mult_div_pow = prep_rls( - Rls {id = "rat_mult_div_pow", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, - (*FIXME.WN051028 append_rls "e_rls-is_polyexp" e_rls - [Calc ("Poly.is'_polyexp", eval_is_polyexp "")], - with this correction ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ we get - error "rational.sml.sml: diff.behav. in norm_Rational_mg 29" etc. - thus we decided to go on with this flaw*) - srls = Erls, calc = [], - rules = [Thm ("rat_mult",num_str rat_mult), - (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) - Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r), - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) - - Thm ("real_divide_divide1_mg", real_divide_divide1_mg), - (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*) - Thm ("real_divide_divide1_eq", real_divide_divide1_eq), - (*"?x / (?y / ?z) = ?x * ?z / ?y"*) - Thm ("real_divide_divide2_eq", real_divide_divide2_eq), - (*"?x / ?y / ?z = ?x / (?y * ?z)"*) - Calc ("HOL.divide" ,eval_cancel "#divide_"), - - Thm ("rat_power", num_str rat_power) - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* ------------------------------------------------------------------ *) -val rat_reduce_1 = prep_rls( - Rls {id = "rat_reduce_1", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], - rules = [Thm ("real_divide_1",num_str real_divide_1), - (*"?x / 1 = ?x"*) - Thm ("real_mult_1",num_str real_mult_1) - (*"1 * z = z"*) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* ------------------------------------------------------------------ *) -(*. looping part of norm_Rational(*_mg*) .*) -val norm_Rational_rls = prep_rls( - Rls {id = "norm_Rational_rls", preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [Rls_ common_nominator_p_rls, - Rls_ rat_mult_div_pow, - Rls_ make_rat_poly_with_parentheses, - Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*) - Rls_ rat_reduce_1 - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* ------------------------------------------------------------------ *) -(*040109 'norm_Rational'(by RL) replaced by 'norm_Rational_mg'(MG) - just be renaming:*) -val norm_Rational(*_mg*) = prep_rls( - Seq {id = "norm_Rational"(*_mg*), preconds = [], - rew_ord = ("dummy_ord",dummy_ord), - erls = norm_rat_erls, srls = Erls, calc = [], - rules = [Rls_ discard_minus_, - Rls_ rat_mult_poly,(* removes double fractions like a/b/c *) - Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*) - Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*) - Rls_ norm_Rational_rls, (* the main rls, looping (#) *) - Rls_ discard_parentheses_ (* mult only *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -(* ------------------------------------------------------------------ *) - - -ruleset' := overwritelthy thy (!ruleset', - [("calculate_Rational", calculate_Rational), - ("calc_rat_erls",calc_rat_erls), - ("rational_erls", rational_erls), - ("cancel_p", cancel_p), - ("cancel", cancel), - ("common_nominator_p", common_nominator_p), - ("common_nominator_p_rls", common_nominator_p_rls), - ("common_nominator" , common_nominator), - ("discard_minus", discard_minus), - ("powers_erls", powers_erls), - ("powers", powers), - ("rat_mult_divide", rat_mult_divide), - ("reduce_0_1_2", reduce_0_1_2), - ("rat_reduce_1", rat_reduce_1), - ("norm_rat_erls", norm_rat_erls), - ("norm_Rational", norm_Rational), - ("norm_Rational_rls", norm_Rational_rls), - ("norm_Rational_parenthesized", norm_Rational_parenthesized), - ("rat_mult_poly", rat_mult_poly), - ("rat_mult_div_pow", rat_mult_div_pow), - ("cancel_p_rls", cancel_p_rls) - ]); - -calclist':= overwritel (!calclist', - [("is_expanded", ("Rational.is'_expanded", eval_is_expanded "")) - ]); - -(** problems **) - -store_pbt - (prep_pbt Rational.thy "pbl_simp_rat" [] e_pblID - (["rational","simplification"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_ratpolyexp"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "Simplify t_", - [["simplification","of_rationals"]])); - -(** methods **) - -(*WN061025 this methods script is copied from (auto-generated) script - of norm_Rational in order to ease repair on inform*) -store_met - (prep_met Rational.thy "met_simp_rat" [] e_metID - (["simplification","of_rationals"], - [("#Given" ,["term t_"]), - ("#Where" ,["t_ is_ratpolyexp"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", - rls' = e_rls, - calc = [], srls = e_rls, - prls = append_rls "simplification_of_rationals_prls" e_rls - [(*for preds in where_*) - Calc ("Rational.is'_ratpolyexp", - eval_is_ratpolyexp "")], - crls = e_rls, nrls = norm_Rational_rls}, -"Script SimplifyScript (t_::real) = \ -\ ((Try (Rewrite_Set discard_minus_ False) @@ \ -\ Try (Rewrite_Set rat_mult_poly False) @@ \ -\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@ \ -\ Try (Rewrite_Set cancel_p_rls False) @@ \ -\ (Repeat \ -\ ((Try (Rewrite_Set common_nominator_p_rls False) @@ \ -\ Try (Rewrite_Set rat_mult_div_pow False) @@ \ -\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@\ -\ Try (Rewrite_Set cancel_p_rls False) @@ \ -\ Try (Rewrite_Set rat_reduce_1 False)))) @@ \ -\ Try (Rewrite_Set discard_parentheses_ False)) \ -\ t_)" - )); - -(* use"../IsacKnowledge/Rational.ML"; - use"IsacKnowledge/Rational.ML"; - use"Rational.ML"; - *) - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Rational.thy --- a/src/Tools/isac/IsacKnowledge/Rational.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -(* rationals, i.e. fractions of multivariate polynomials over the real field - author: isac team - Copyright (c) isac team 2002 - Use is subject to license terms. - - depends on Poly (and not on Atools), because - fractions with _normalized_ polynomials are canceled, added, etc. - - use_thy_only"IsacKnowledge/Rational"; - use_thy"../IsacKnowledge/Rational"; - use_thy"IsacKnowledge/Rational"; - - remove_thy"Rational"; - use_thy"IsacKnowledge/Isac"; - use_thy_only"IsacKnowledge/Rational"; - -*) - -Rational = Poly + - -consts - - is'_expanded :: "real => bool" ("_ is'_expanded") (*RL->Poly.thy*) - is'_ratpolyexp :: "real => bool" ("_ is'_ratpolyexp") - -rules (*.not contained in Isabelle2002, - stated as axioms, TODO: prove as theorems*) - - mult_cross "[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)" - mult_cross1 " b ~= 0 ==> (a / b = c ) = (a = b * c)" - mult_cross2 " d ~= 0 ==> (a = c / d) = (a * d = c)" - - add_minus "a + b - b = a"(*RL->Poly.thy*) - add_minus1 "a - b + b = a"(*RL->Poly.thy*) - - rat_mult "a / b * (c / d) = a * c / (b * d)"(*?Isa02*) - rat_mult2 "a / b * c = a * c / b "(*?Isa02*) - - rat_mult_poly_l "c is_polyexp ==> c * (a / b) = c * a / b" - rat_mult_poly_r "c is_polyexp ==> (a / b) * c = a * c / b" - -(*real_times_divide1_eq .. Isa02*) - real_times_divide_1_eq "-1 * (c / d) =-1 * c / d " - real_times_divide_num "a is_const ==> \ - \a * (c / d) = a * c / d " - - real_mult_div_cancel2 "k ~= 0 ==> m * k / (n * k) = m / n" -(*real_mult_div_cancel1 "k ~= 0 ==> k * m / (k * n) = m / n"..Isa02*) - - real_divide_divide1 "y ~= 0 ==> (u / v) / (y / z) = (u / v) * (z / y)" - real_divide_divide1_mg "y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)" -(*real_divide_divide2_eq "x / y / z = x / (y * z)"..Isa02*) - - rat_power "(a / b)^^^n = (a^^^n) / (b^^^n)" - - - rat_add "[| a is_const; b is_const; c is_const; d is_const |] ==> \ - \a / c + b / d = (a * d + b * c) / (c * d)" - rat_add_assoc "[| a is_const; b is_const; c is_const; d is_const |] ==> \ - \a / c +(b / d + e) = (a * d + b * c)/(d * c) + e" - rat_add1 "[| a is_const; b is_const; c is_const |] ==> \ - \a / c + b / c = (a + b) / c" - rat_add1_assoc "[| a is_const; b is_const; c is_const |] ==> \ - \a / c + (b / c + e) = (a + b) / c + e" - rat_add2 "[| a is_const; b is_const; c is_const |] ==> \ - \a / c + b = (a + b * c) / c" - rat_add2_assoc "[| a is_const; b is_const; c is_const |] ==> \ - \a / c + (b + e) = (a + b * c) / c + e" - rat_add3 "[| a is_const; b is_const; c is_const |] ==> \ - \a + b / c = (a * c + b) / c" - rat_add3_assoc "[| a is_const; b is_const; c is_const |] ==> \ - \a + (b / c + e) = (a * c + b) / c + e" - - - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Root.ML --- a/src/Tools/isac/IsacKnowledge/Root.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,299 +0,0 @@ -(* collecting all knowledge for Root - created by: - date: - changed by: rlang - last change by: rlang - date: 02.10.24 -*) - -(* use"../knowledge/Root.ML"; - use"IsacKnowledge/Root.ML"; - use"Root.ML"; - - remove_thy"Root"; - use_thy"IsacKnowledge/Isac"; - - use"ROOT.ML"; - cd"knowledge"; - *) -"******* Root.ML begin *******"; -theory' := overwritel (!theory', [("Root.thy",Root.thy)]); -(*-------------------------functions---------------------*) -(*evaluation square-root over the integers*) -fun eval_sqrt (thmid:string) (op_:string) (t as - (Const(op0,t0) $ arg)) thy = - (case arg of - Free (n1,t1) => - (case int_of_str n1 of - SOME ni => - if ni < 0 then NONE - else - let val fact = squfact ni; - in if fact*fact = ni - then SOME ("#sqrt #"^(string_of_int ni)^" = #" - ^(string_of_int (if ni = 0 then 0 - else ni div fact)), - Trueprop $ mk_equality (t, term_of_num t1 fact)) - else if fact = 1 then NONE - else SOME ("#sqrt #"^(string_of_int ni)^" = sqrt (#" - ^(string_of_int fact)^" * #" - ^(string_of_int fact)^" * #" - ^(string_of_int (ni div (fact*fact))^")"), - Trueprop $ - (mk_equality - (t, - (mk_factroot op0 t1 fact - (ni div (fact*fact)))))) - end - | NONE => NONE) - | _ => NONE) - - | eval_sqrt _ _ _ _ = NONE; -(*val (thmid, op_, t as Const(op0,t0) $ arg) = ("","", str2term "sqrt 0"); -> eval_sqrt thmid op_ t thy; -> val Free (n1,t1) = arg; -> val SOME ni = int_of_str n1; -*) - -calclist':= overwritel (!calclist', - [("SQRT" ,("Root.sqrt" ,eval_sqrt "#sqrt_")) - (*different types for 'sqrt 4' --- 'Calculate sqrt_'*) - ]); - - -local (* Vers. 7.10.99.A *) - -open Term; (* for type order = EQUAL | LESS | GREATER *) - -fun pr_ord EQUAL = "EQUAL" - | pr_ord LESS = "LESS" - | pr_ord GREATER = "GREATER"; - -fun dest_hd' (Const (a, T)) = (* ~ term.ML *) - (case a of "Root.sqrt" => ((("|||", 0), T), 0) (*WN greatest *) - | _ => (((a, 0), T), 0)) - | dest_hd' (Free (a, T)) = (((a, 0), T), 1) - | dest_hd' (Var v) = (v, 2) - | dest_hd' (Bound i) = ((("", i), dummyT), 3) - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); -fun size_of_term' (Const(str,_) $ t) = - (case str of "Root.sqrt" => (1000 + size_of_term' t) - | _ => 1 + size_of_term' t) - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body - | size_of_term' (f $ t) = size_of_term' f + size_of_term' t - | size_of_term' _ = 1; -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) - | term_ord' pr thy (t, u) = - (if pr then - let - val (f, ts) = strip_comb t and (g, us) = strip_comb u; - val _=writeln("t= f@ts= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\""); - val _=writeln("u= g@us= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\""); - val _=writeln("size_of_term(t,u)= ("^ - (string_of_int(size_of_term' t))^", "^ - (string_of_int(size_of_term' u))^")"); - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); - val _=writeln("terms_ord(ts,us) = "^ - ((pr_ord o terms_ord str false)(ts,us))); - val _=writeln("-------"); - in () end - else (); - case int_ord (size_of_term' t, size_of_term' u) of - EQUAL => - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) - | ord => ord) - end - | ord => ord) -and hd_ord (f, g) = (* ~ term.ML *) - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) -and terms_ord str pr (ts, us) = - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); - -in -(* associates a+(b+c) => (a+b)+c = a+b+c ... avoiding parentheses - by (1) size_of_term: less(!) to right, size_of 'sqrt (...)' = 1 - (2) hd_ord: greater to right, 'sqrt' < numerals < variables - (3) terms_ord: recurs. on args, greater to right -*) - -(*args - pr: print trace, WN0509 'sqrt_right true' not used anymore - thy: - subst: no bound variables, only Root.sqrt - tu: the terms to compare (t1, t2) ... *) -fun sqrt_right (pr:bool) thy (_:subst) tu = - (term_ord' pr thy(***) tu = LESS ); -end; - -rew_ord' := overwritel (!rew_ord', -[("termlessI", termlessI), - ("sqrt_right", sqrt_right false (theory "Pure")) - ]); - -(*-------------------------rulse-------------------------*) -val Root_crls = - append_rls "Root_crls" Atools_erls - [Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"), - Calc ("HOL.divide",eval_cancel "#divide_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#sub_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("op =",eval_equal "#equal_") - ]; - -val Root_erls = - append_rls "Root_erls" Atools_erls - [Thm ("real_unari_minus",num_str real_unari_minus), - Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"), - Calc ("HOL.divide",eval_cancel "#divide_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#sub_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("op =",eval_equal "#equal_") - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("Root_erls",Root_erls) (*FIXXXME:del with rls.rls'*) - ]); - -val make_rooteq = prep_rls( - Rls{id = "make_rooteq", preconds = []:term list, - rew_ord = ("sqrt_right", sqrt_right false Root.thy), - erls = Atools_erls, srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_diff_minus",num_str real_diff_minus), - (*"a - b = a + (-1) * b"*) - - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) - - Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) - Thm ("real_mult_assoc",num_str real_mult_assoc), (**) - Thm ("real_add_commute",num_str real_add_commute), (**) - Thm ("real_add_left_commute",num_str real_add_left_commute), (**) - Thm ("real_add_assoc",num_str real_add_assoc), (**) - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("make_rooteq", make_rooteq) - ]); - -val expand_rootbinoms = prep_rls( - Rls{id = "expand_rootbinoms", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = Atools_erls, srls = Erls, - calc = [], - (*asm_thm = [],*) - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), - (*"(a + b)*(a + b) = ...*) - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) - Thm ("real_minus_binom_times",num_str real_minus_binom_times), - (*"(a - b)*(a - b) = ...*) - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) - (*RL 020915*) - Thm ("real_pp_binom_times",num_str real_pp_binom_times), - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) - Thm ("real_pm_binom_times",num_str real_pm_binom_times), - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) - Thm ("real_mp_binom_times",num_str real_mp_binom_times), - (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*) - Thm ("real_mm_binom_times",num_str real_mm_binom_times), - (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*) - Thm ("realpow_mul",num_str realpow_mul), - (*(a*b)^^^n = a^^^n * b^^^n*) - - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), (*"0 + z = z"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#sub_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("HOL.divide" ,eval_cancel "#divide_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - Calc ("Atools.pow", eval_binop "#power_"), - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op -", eval_binop "#sub_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("HOL.divide" ,eval_cancel "#divide_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - Calc ("Atools.pow", eval_binop "#power_") - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); - - -ruleset' := overwritelthy thy (!ruleset', - [("expand_rootbinoms", expand_rootbinoms) - ]); -"******* Root.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Root.thy --- a/src/Tools/isac/IsacKnowledge/Root.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -(* theory collecting all knowledge for Root - created by: - date: - changed by: rlang - last change by: rlang - date: 02.10.21 -*) - -(* use_thy_only"IsacKnowledge/Root"; - remove_thy"Root"; - use_thy"IsacKnowledge/Isac"; -*) -Root = Simplify + - -(*-------------------- consts------------------------------------------------*) -consts - - sqrt :: "real => real" (*"(sqrt _ )" [80] 80*) - nroot :: "[real, real] => real" - -(*----------------------scripts-----------------------*) - -(*-------------------- rules------------------------------------------------*) -rules (*.not contained in Isabelle2002, - stated as axioms, TODO: prove as theorems; - theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*) - - root_plus_minus "0 <= b ==> \ - \(a^^^2 = b) = ((a = sqrt b) | (a = (-1)*sqrt b))" - root_false "b < 0 ==> (a^^^2 = b) = False" - - (* for expand_rootbinom *) - real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d" - real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d" - real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d" - real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d" - real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" - real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3" - realpow_mul "(a*b)^^^n = a^^^n * b^^^n" - - real_diff_minus "a - b = a + (-1) * b" - real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2" - real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2" - real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2" - real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2" - real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2" - real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2" - - real_root_positive "0 <= a ==> (x ^^^ 2 = a) = (x = sqrt a)" - real_root_negative "a < 0 ==> (x ^^^ 2 = a) = False" - - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootEq.ML --- a/src/Tools/isac/IsacKnowledge/RootEq.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,505 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* theory collecting all knowledge for RootEquations - created by: rlang - date: 02.09 - changed by: rlang - last change by: rlang - date: 02.11.14 -*) - -(* use"IsacKnowledge/RootEq.ML"; - use"RootEq.ML"; - - use"ROOT.ML"; - cd"knowledge"; - - remove_thy"RootEq"; - use_thy"IsacKnowledge/Isac"; - *) -"******* RootEq.ML begin *******"; - -theory' := overwritel (!theory', [("RootEq.thy",RootEq.thy)]); -(*-------------------------functions---------------------*) -(* true if bdv is under sqrt of a Equation*) -fun is_rootTerm_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun findroot (_ $ _ $ _ $ _) v = raise error("is_rootTerm_in:") - (* at the moment there is no term like this, but ....*) - | findroot (t as (Const ("Root.nroot",_) $ _ $ t3)) v = coeff_in t3 v - | findroot (_ $ t2 $ t3) v = (findroot t2 v) orelse (findroot t3 v) - | findroot (t as (Const ("Root.sqrt",_) $ t2)) v = coeff_in t2 v - | findroot (_ $ t2) v = (findroot t2 v) - | findroot _ _ = false; - in - findroot t v - end; - - fun is_sqrtTerm_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun findsqrt (_ $ _ $ _ $ _) v = raise error("is_sqrteqation_in:") - (* at the moment there is no term like this, but ....*) - | findsqrt (_ $ t1 $ t2) v = (findsqrt t1 v) orelse (findsqrt t2 v) - | findsqrt (t as (Const ("Root.sqrt",_) $ a)) v = coeff_in a v - | findsqrt (_ $ t1) v = (findsqrt t1 v) - | findsqrt _ _ = false; - in - findsqrt t v - end; - -(* RL: 030518: Is in the rightest subterm of a term a sqrt with bdv, -and the subterm ist connected with + or * --> is normalized*) - fun is_normSqrtTerm_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun isnorm (_ $ _ $ _ $ _) v = raise error("is_normSqrtTerm_in:") - (* at the moment there is no term like this, but ....*) - | isnorm (Const ("op +",_) $ _ $ t2) v = is_sqrtTerm_in t2 v - | isnorm (Const ("op *",_) $ _ $ t2) v = is_sqrtTerm_in t2 v - | isnorm (Const ("op -",_) $ _ $ _) v = false - | isnorm (Const ("HOL.divide",_) $ t1 $ t2) v = (is_sqrtTerm_in t1 v) orelse - (is_sqrtTerm_in t2 v) - | isnorm (Const ("Root.sqrt",_) $ t1) v = coeff_in t1 v - | isnorm (_ $ t1) v = is_sqrtTerm_in t1 v - | isnorm _ _ = false; - in - isnorm t v - end; - -fun eval_is_rootTerm_in _ _ (p as (Const ("RootEq.is'_rootTerm'_in",_) $ t $ v)) _ = - if is_rootTerm_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_rootTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - -fun eval_is_sqrtTerm_in _ _ (p as (Const ("RootEq.is'_sqrtTerm'_in",_) $ t $ v)) _ = - if is_sqrtTerm_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_sqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - -fun eval_is_normSqrtTerm_in _ _ (p as (Const ("RootEq.is'_normSqrtTerm'_in",_) $ t $ v)) _ = - if is_normSqrtTerm_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_normSqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - -(*-------------------------rulse-------------------------*) -val RootEq_prls = (*15.10.02:just the following order due to subterm evaluation*) - append_rls "RootEq_prls" e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Tools.lhs" ,eval_lhs ""), - Calc ("Tools.rhs" ,eval_rhs ""), - Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""), - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), - Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""), - Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false), - Thm ("or_true",num_str or_true), - Thm ("or_false",num_str or_false) - ]; - -val RootEq_erls = - append_rls "RootEq_erls" Root_erls - [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq) - ]; - -val RootEq_crls = - append_rls "RootEq_crls" Root_crls - [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq) - ]; - -val rooteq_srls = - append_rls "rooteq_srls" e_rls - [Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""), - Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""), - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in "") - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("RootEq_erls",RootEq_erls), (*FIXXXME:del with rls.rls'*) - ("rooteq_srls",rooteq_srls) - ]); - -(*isolate the bound variable in an sqrt equation; 'bdv' is a meta-constant*) - val sqrt_isolate = prep_rls( - Rls {id = "sqrt_isolate", preconds = [], rew_ord = ("termlessI",termlessI), - erls = RootEq_erls, srls = Erls, calc = [], - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), - ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""), - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), - ("sqrt_square_equation_right_6","")],*) - rules = [ - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) - Thm("sqrt_square_equation_both_1",num_str sqrt_square_equation_both_1), - (* (sqrt a + sqrt b = sqrt c + sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *) - Thm("sqrt_square_equation_both_2",num_str sqrt_square_equation_both_2), - (* (sqrt a - sqrt b = sqrt c + sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *) - Thm("sqrt_square_equation_both_3",num_str sqrt_square_equation_both_3), - (* (sqrt a + sqrt b = sqrt c - sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *) - Thm("sqrt_square_equation_both_4",num_str sqrt_square_equation_both_4), - (* (sqrt a - sqrt b = sqrt c - sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *) - Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *) - Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *) - Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *) - Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *) - 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 *) - Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *) - (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *) - Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *) - Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *) - Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*) - Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *) - 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)*) - Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *) - (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *) - Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1), - (* sqrt(x)=b -> x=b^2 *) - Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2), - (* c*sqrt(x)=b -> c^2*x=b^2 *) - Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3), - (* c/sqrt(x)=b -> c^2/x=b^2 *) - Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4), - (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *) - Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5), - (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *) - Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6), - (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *) - Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1), - (* a=sqrt(x) ->a^2=x *) - Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2), - (* a=c*sqrt(x) ->a^2=c^2*x *) - Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3), - (* a=c/sqrt(x) ->a^2=c^2/x *) - Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4), - (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *) - Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5), - (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *) - Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6) - (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("sqrt_isolate",sqrt_isolate) - ]); -(* -- left 28.08.02--*) -(*isolate the bound variable in an sqrt left equation; 'bdv' is a meta-constant*) - val l_sqrt_isolate = prep_rls( - Rls {id = "l_sqrt_isolate", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = RootEq_erls, srls = Erls, calc = [], - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), - ("sqrt_square_equation_left_6","")],*) - rules = [ - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) - Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *) - Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *) - Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *) - Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *) - 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 *) - Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *) - (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *) - Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1), - (* sqrt(x)=b -> x=b^2 *) - Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2), - (* a*sqrt(x)=b -> a^2*x=b^2*) - Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3), - (* c/sqrt(x)=b -> c^2/x=b^2 *) - Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4), - (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *) - Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5), - (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *) - Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6) - (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("l_sqrt_isolate",l_sqrt_isolate) - ]); - -(* -- right 28.8.02--*) -(*isolate the bound variable in an sqrt right equation; 'bdv' is a meta-constant*) - val r_sqrt_isolate = prep_rls( - Rls {id = "r_sqrt_isolate", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = RootEq_erls, srls = Erls, calc = [], - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_right_1",""), - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), - ("sqrt_square_equation_right_6","")],*) - rules = [ - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) - Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *) - Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *) - Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*) - Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *) - 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)*) - Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *) - (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *) - Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1), - (* a=sqrt(x) ->a^2=x *) - Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2), - (* a=c*sqrt(x) ->a^2=c^2*x *) - Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3), - (* a=c/sqrt(x) ->a^2=c^2/x *) - Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4), - (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *) - Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5), - (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *) - Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6) - (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("r_sqrt_isolate",r_sqrt_isolate) - ]); - -val rooteq_simplify = prep_rls( - Rls {id = "rooteq_simplify", - preconds = [], rew_ord = ("termlessI",termlessI), - erls = RootEq_erls, srls = Erls, calc = [], - (*asm_thm = [("sqrt_square_1","")],*) - rules = [Thm ("real_assoc_1",num_str real_assoc_1), (* a+(b+c) = a+b+c *) - Thm ("real_assoc_2",num_str real_assoc_2), (* a*(b*c) = a*b*c *) - Calc ("op +",eval_binop "#add_"), - Calc ("op -",eval_binop "#sub_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - Thm("real_plus_binom_pow2",num_str real_plus_binom_pow2), - Thm("real_minus_binom_pow2",num_str real_minus_binom_pow2), - Thm("realpow_mul",num_str realpow_mul), (* (a * b)^n = a^n * b^n*) - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt b * sqrt c = sqrt(b*c) *) - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a * sqrt a * sqrt b = a * sqrt(a*b) *) - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) = a *) - Thm("sqrt_square_1",num_str sqrt_square_1) (* sqrt a ^^^ 2 = a *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); - ruleset' := overwritelthy thy (!ruleset', - [("rooteq_simplify",rooteq_simplify) - ]); - -(*-------------------------Problem-----------------------*) -(* -(get_pbt ["root","univariate","equation"]); -show_ptyps(); -*) -(* ---------root----------- *) -store_pbt - (prep_pbt RootEq.thy "pbl_equ_univ_root" [] e_pblID - (["root","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_rootTerm_in (v_::real) | \ - \(rhs e_) is_rootTerm_in (v_::real)"]), - ("#Find" ,["solutions v_i_"]) - ], - RootEq_prls, SOME "solve (e_::bool, v_)", - [])); -(* ---------sqrt----------- *) -store_pbt - (prep_pbt RootEq.thy "pbl_equ_univ_root_sq" [] e_pblID - (["sq","root","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ - \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\ - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ - \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]), - ("#Find" ,["solutions v_i_"]) - ], - RootEq_prls, SOME "solve (e_::bool, v_)", - [["RootEq","solve_sq_root_equation"]])); -(* ---------normalize----------- *) -store_pbt - (prep_pbt RootEq.thy "pbl_equ_univ_root_norm" [] e_pblID - (["normalize","root","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ - \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \ - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ - \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]), - ("#Find" ,["solutions v_i_"]) - ], - RootEq_prls, SOME "solve (e_::bool, v_)", - [["RootEq","norm_sq_root_equation"]])); - -(*-------------------------methods-----------------------*) -(* ---- root 20.8.02 ---*) -store_met - (prep_met RootEq.thy "met_rooteq" [] e_metID - (["RootEq"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=RootEq_crls, nrls=norm_Poly(*, - asm_rls=[],asm_thm=[]*)}, "empty_script")); -(*-- normalize 20.10.02 --*) -store_met - (prep_met RootEq.thy "met_rooteq_norm" [] e_metID - (["RootEq","norm_sq_root_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ - \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \ - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ - \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=RootEq_erls, - srls=e_rls, - prls=RootEq_prls, - calc=[], - crls=RootEq_crls, nrls=norm_Poly(*, - asm_rls=[], - asm_thm=[("sqrt_square_1","")]*)}, - "Script Norm_sq_root_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Repeat(Try (Rewrite makex1_x False))) @@ \ - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ - \ (Try (Rewrite_Set rooteq_simplify True)) @@ \ - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ - \ (Try (Rewrite_Set rooteq_simplify True))) e_ \ - \ in ((SubProblem (RootEq_,[univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_])))" - )); - -store_met - (prep_met RootEq.thy "met_rooteq_sq" [] e_metID - (["RootEq","solve_sq_root_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ - \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\ - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ - \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=RootEq_erls, - srls = rooteq_srls, - prls = RootEq_prls, - calc = [], - crls=RootEq_crls, nrls=norm_Poly(*, - asm_rls = [], - asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), - ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""), - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), - ("sqrt_square_equation_right_6","")]*)}, -"Script Solve_sq_root_equation (e_::bool) (v_::real) = \ -\(let e_ = \ -\ ((Try (Rewrite_Set_Inst [(bdv,v_::real)] sqrt_isolate True)) @@ \ -\ (Try (Rewrite_Set rooteq_simplify True)) @@ \ -\ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ -\ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ -\ (Try (Rewrite_Set rooteq_simplify True))) e_;\ -\ (L_::bool list) = \ -\ (if (((lhs e_) is_sqrtTerm_in v_) | ((rhs e_) is_sqrtTerm_in v_))\ -\ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ -\ [no_met]) [bool_ e_, real_ v_]) \ -\ else (SubProblem (RootEq_,[univariate,equation], \ -\ [no_met]) [bool_ e_, real_ v_])) \ -\ in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -(*-- right 28.08.02 --*) -store_met - (prep_met RootEq.thy "met_rooteq_sq_right" [] e_metID - (["RootEq","solve_right_sq_root_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(rhs e_) is_sqrtTerm_in v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=RootEq_erls, - srls=e_rls, - prls=RootEq_prls, - calc=[], - crls=RootEq_crls, nrls=norm_Poly(*, - asm_rls=[], - asm_thm=[("sqrt_square_1",""),("sqrt_square_1",""),("sqrt_square_equation_right_1",""), - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), - ("sqrt_square_equation_right_6","")]*)}, - "Script Solve_right_sq_root_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] r_sqrt_isolate False)) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False))) e_\ - \ in if ((rhs e_) is_sqrtTerm_in v_) \ - \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_]) \ - \ else ((SubProblem (RootEq_,[univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_])))" - )); - -(*-- left 28.08.02 --*) -store_met - (prep_met RootEq.thy "met_rooteq_sq_left" [] e_metID - (["RootEq","solve_left_sq_root_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(lhs e_) is_sqrtTerm_in v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=RootEq_erls, - srls=e_rls, - prls=RootEq_prls, - calc=[], - crls=RootEq_crls, nrls=norm_Poly(*, - asm_rls=[], - asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_left_1",""), - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), - ("sqrt_square_equation_left_6","")]*)}, - "Script Solve_left_sq_root_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] l_sqrt_isolate False)) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False))) e_\ - \ in if ((lhs e_) is_sqrtTerm_in v_) \ - \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_]) \ - \ else ((SubProblem (RootEq_,[univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_])))" - )); - -calclist':= overwritel (!calclist', - [("is_rootTerm_in", ("RootEq.is'_rootTerm'_in", - eval_is_rootTerm_in"")), - ("is_sqrtTerm_in", ("RootEq.is'_sqrtTerm'_in", - eval_is_sqrtTerm_in"")), - ("is_normSqrtTerm_in", ("RootEq.is_normSqrtTerm_in", - eval_is_normSqrtTerm_in"")) - ]);(*("", ("", "")),*) -"******* RootEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootEq.thy --- a/src/Tools/isac/IsacKnowledge/RootEq.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* collecting all knowledge for Root Equations - created by: rlang - date: 02.08 - changed by: rlang - last change by: rlang - date: 02.11.14 -*) -(* use"../knowledge/RootEq.ML"; - use"knowledge/RootEq.ML"; - use"RootEq.ML"; - - remove_thy"RootEq"; - use_thy"Isac"; - - use"ROOT.ML"; - cd"knowledge"; - *) - -RootEq = Root + - -(*-------------------- consts------------------------------------------------*) -consts - (*-------------------------root-----------------------*) - is'_rootTerm'_in :: [real, real] => bool ("_ is'_rootTerm'_in _") - is'_sqrtTerm'_in :: [real, real] => bool ("_ is'_sqrtTerm'_in _") - is'_normSqrtTerm'_in :: [real, real] => bool ("_ is'_normSqrtTerm'_in _") - (*----------------------scripts-----------------------*) - Norm'_sq'_root'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Norm'_sq'_root'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_sq'_root'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_sq'_root'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_left'_sq'_root'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_left'_sq'_root'_equation (_ _ =))// \ - \ (_))" 9) - Solve'_right'_sq'_root'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_right'_sq'_root'_equation (_ _ =))// \ - \ (_))" 9) - -(*-------------------- rules------------------------------------------------*) -rules - -(* normalize *) - makex1_x - "a^^^1 = a" - real_assoc_1 - "a+(b+c) = a+b+c" - real_assoc_2 - "a*(b*c) = a*b*c" - - (* simplification of root*) - sqrt_square_1 - "[|0 <= a|] ==> (sqrt a)^^^2 = a" - sqrt_square_2 - "sqrt (a ^^^ 2) = a" - sqrt_times_root_1 - "sqrt a * sqrt b = sqrt(a*b)" - sqrt_times_root_2 - "a * sqrt b * sqrt c = a * sqrt(b*c)" - - (* isolate one root on the LEFT or RIGHT hand side of the equation *) - sqrt_isolate_l_add1 - "[|bdv occurs_in c|] ==> (a + b*sqrt(c) = d) = (b * sqrt(c) = d+ (-1) * a)" - sqrt_isolate_l_add2 - "[|bdv occurs_in c|] ==>(a + sqrt(c) = d) = ((sqrt(c) = d+ (-1) * a))" - sqrt_isolate_l_add3 - "[|bdv occurs_in c|] ==> (a + b*(e/sqrt(c)) = d) = (b * (e/sqrt(c)) = d+ (-1) * a)" - sqrt_isolate_l_add4 - "[|bdv occurs_in c|] ==>(a + b/(f*sqrt(c)) = d) = (b / (f*sqrt(c)) = d+ (-1) * a)" - sqrt_isolate_l_add5 - "[|bdv occurs_in c|] ==> (a + b*(e/(f*sqrt(c))) = d) = (b * (e/(f*sqrt(c))) = d+ (-1) * a)" - sqrt_isolate_l_add6 - "[|bdv occurs_in c|] ==>(a + b/sqrt(c) = d) = (b / sqrt(c) = d+ (-1) * a)" - sqrt_isolate_r_add1 - "[|bdv occurs_in f|] ==>(a = d + e*sqrt(f)) = (a + (-1) * d = e*sqrt(f))" - sqrt_isolate_r_add2 - "[|bdv occurs_in f|] ==>(a = d + sqrt(f)) = (a + (-1) * d = sqrt(f))" - (* small hack: thm 3,5,6 are not needed if rootnormalize is well done*) - sqrt_isolate_r_add3 - "[|bdv occurs_in f|] ==>(a = d + e*(g/sqrt(f))) = (a + (-1) * d = e*(g/sqrt(f)))" - sqrt_isolate_r_add4 - "[|bdv occurs_in f|] ==>(a = d + g/sqrt(f)) = (a + (-1) * d = g/sqrt(f))" - sqrt_isolate_r_add5 - "[|bdv occurs_in f|] ==>(a = d + e*(g/(h*sqrt(f)))) = (a + (-1) * d = e*(g/(h*sqrt(f))))" - sqrt_isolate_r_add6 - "[|bdv occurs_in f|] ==>(a = d + g/(h*sqrt(f))) = (a + (-1) * d = g/(h*sqrt(f)))" - - (* eliminate isolates sqrt *) - sqrt_square_equation_both_1 - "[|bdv occurs_in b; bdv occurs_in d|] ==> - ( (sqrt a + sqrt b = sqrt c + sqrt d) = - (a+2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))" - sqrt_square_equation_both_2 - "[|bdv occurs_in b; bdv occurs_in d|] ==> - ( (sqrt a - sqrt b = sqrt c + sqrt d) = - (a - 2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))" - sqrt_square_equation_both_3 - "[|bdv occurs_in b; bdv occurs_in d|] ==> - ( (sqrt a + sqrt b = sqrt c - sqrt d) = - (a + 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))" - sqrt_square_equation_both_4 - "[|bdv occurs_in b; bdv occurs_in d|] ==> - ( (sqrt a - sqrt b = sqrt c - sqrt d) = - (a - 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))" - sqrt_square_equation_left_1 - "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (sqrt (a) = b) = (a = (b^^^2)))" - sqrt_square_equation_left_2 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( (c*sqrt(a) = b) = (c^^^2*a = b^^^2))" - sqrt_square_equation_left_3 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( c/sqrt(a) = b) = (c^^^2 / a = b^^^2)" - (* small hack: thm 4-6 are not needed if rootnormalize is well done*) - sqrt_square_equation_left_4 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( (c*(d/sqrt (a)) = b) = (c^^^2*(d^^^2/a) = b^^^2))" - sqrt_square_equation_left_5 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( c/(d*sqrt(a)) = b) = (c^^^2 / (d^^^2*a) = b^^^2)" - sqrt_square_equation_left_6 - "[|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))" - sqrt_square_equation_right_1 - "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = sqrt (b)) = (a^^^2 = b))" - sqrt_square_equation_right_2 - "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c*sqrt (b)) = ((a^^^2) = c^^^2*b))" - sqrt_square_equation_right_3 - "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c/sqrt (b)) = (a^^^2 = c^^^2/b))" - (* small hack: thm 4-6 are not needed if rootnormalize is well done*) - sqrt_square_equation_right_4 - "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c*(d/sqrt (b))) = ((a^^^2) = c^^^2*(d^^^2/b)))" - sqrt_square_equation_right_5 - "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c/(d*sqrt (b))) = (a^^^2 = c^^^2/(d^^^2*b)))" - sqrt_square_equation_right_6 - "[|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))))" - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootRat.ML --- a/src/Tools/isac/IsacKnowledge/RootRat.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* collecting all knowledge for Root and Rational - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.10.21 -*) -(* use"knowledge/RootRat.ML"; - use"RootRat.ML"; - - use"ROOT.ML"; - cd"knowledge"; - - remove_thy"RootRat"; - use_thy"Isac"; - *) - -"******* RootRat.ML begin *******"; -theory' := overwritel (!theory', [("RootRat.thy",RootRat.thy)]); - -(*-------------------------functions---------------------*) - -(*-------------------------rulse-------------------------*) -val rootrat_erls = - merge_rls "rootrat_erls" Root_erls - (merge_rls "" rational_erls - (append_rls "" e_rls - [])); - -ruleset' := overwritelthy thy (!ruleset', - [("rootrat_erls",rootrat_erls) (*FIXXXME:del with rls.rls'*) - ]); - -(*.calculate numeral groundterms.*) -val calculate_RootRat = - append_rls "calculate_RootRat" calculate_Rational - [Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (* w*(z1.0 + z2.0) = w * z1.0 + w * z2.0 *) - Thm ("real_mult_1",num_str real_mult_1), - (* 1 * z = z *) - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)), - (* "- z1 = -1 * z1" *) - Calc ("Root.sqrt",eval_sqrt "#sqrt_") - ]; -ruleset' := overwritelthy thy (!ruleset', - [("calculate_RootRat",calculate_RootRat)]); - - -"******* RootRat.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootRat.thy --- a/src/Tools/isac/IsacKnowledge/RootRat.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* collecting all knowledge for Root and Rational - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.10.20 -*) - -RootRat = Root + Rational + -(*-------------------- consts------------------------------------------------*) - - -(*-------------------- rules------------------------------------------------*) - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootRatEq.ML --- a/src/Tools/isac/IsacKnowledge/RootRatEq.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -(*.(c) by Richard Lang, 2003 .*) -(* collecting all knowledge for Root and Rational Equations - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.11.04 -*) - -(* use"knowledge/RootRatEq.ML"; - use"RootRatEq.ML"; - - use"ROOT.ML"; - cd"knowledge"; - - remove_thy"RootRatEq"; - use_thy"Isac"; - *) - -"******* RootRatEq.ML begin *******"; -theory' := overwritel (!theory', [("RootRatEq.thy",RootRatEq.thy)]); - -(*-------------------------functions---------------------*) -(* true if denominator contains (sq)root in + or - term - 1/(sqrt(x+3)*(x+4)) -> false; 1/(sqrt(x)+2) -> true - if false then (term)^2 contains no (sq)root *) -fun is_rootRatAddTerm_in t v = - let - fun coeff_in c v = member op = (vars c) v; - fun rootadd (t as (Const ("op +",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse - (is_rootTerm_in t3 v) - | rootadd (t as (Const ("op -",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse - (is_rootTerm_in t3 v) - | rootadd _ _ = false; - fun findrootrat (_ $ _ $ _ $ _) v = raise error("is_rootRatAddTerm_in:") - (* at the moment there is no term like this, but ....*) - | findrootrat (t as (Const ("HOL.divide",_) $ _ $ t3)) v = - if (is_rootTerm_in t3 v) then rootadd t3 v else false - | findrootrat (_ $ t1 $ t2) v = (findrootrat t1 v) orelse (findrootrat t2 v) - | findrootrat (_ $ t1) v = (findrootrat t1 v) - | findrootrat _ _ = false; - in - findrootrat t v - end; - -fun eval_is_rootRatAddTerm_in _ _ (p as (Const ("RootRatEq.is'_rootRatAddTerm'_in",_) $ t $ v)) _ = - if is_rootRatAddTerm_in t v then - SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.true_const))) - else SOME ((term2str p) ^ " = True", - Trueprop $ (mk_equality (p, HOLogic.false_const))) - | eval_is_rootRatAddTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); - -(*-------------------------rulse-------------------------*) -val RootRatEq_prls = - append_rls "RootRatEq_prls" e_rls - [Calc ("Atools.ident",eval_ident "#ident_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Tools.lhs" ,eval_lhs ""), - Calc ("Tools.rhs" ,eval_rhs ""), - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), - Calc ("RootRatEq.is'_rootRatAddTerm'_in", eval_is_rootRatAddTerm_in ""), - Calc ("op =",eval_equal "#equal_"), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",num_str and_true), - Thm ("and_false",num_str and_false), - Thm ("or_true",num_str or_true), - Thm ("or_false",num_str or_false) - ]; - - -val RooRatEq_erls = - merge_rls "RooRatEq_erls" rootrat_erls - (merge_rls "" RootEq_erls - (merge_rls "" rateq_erls - (append_rls "" e_rls - []))); - -val RootRatEq_crls = - merge_rls "RootRatEq_crls" rootrat_erls - (merge_rls "" RootEq_erls - (merge_rls "" rateq_erls - (append_rls "" e_rls - []))); - -ruleset' := overwritelthy thy (!ruleset', - [("RooRatEq_erls",RooRatEq_erls) (*FIXXXME:del with rls.rls'*) - ]); - -(* Solves a rootrat Equation *) - val rootrat_solve = prep_rls( - Rls {id = "rootrat_solve", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) - rules = [ Thm("rootrat_equation_left_1",num_str rootrat_equation_left_1), - (* [|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c )) *) - Thm("rootrat_equation_left_2",num_str rootrat_equation_left_2), - (* [|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c )) *) - Thm("rootrat_equation_right_1",num_str rootrat_equation_right_1), - (* [|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e )) *) - Thm("rootrat_equation_right_2",num_str rootrat_equation_right_2) - (* [|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e )) *) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - }:rls); -ruleset' := overwritelthy thy (!ruleset', - [("rootrat_solve",rootrat_solve) - ]); - -(*-----------------------probleme------------------------*) -(* -(get_pbt ["rat","root","univariate","equation"]); -show_ptyps(); -*) -store_pbt - (prep_pbt RootRatEq.thy "pbl_equ_univ_root_sq_rat" [] e_pblID - (["rat","sq","root","univariate","equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) )| \ - \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]), - ("#Find" ,["solutions v_i_"]) - ], - RootRatEq_prls, SOME "solve (e_::bool, v_)", - [["RootRatEq","elim_rootrat_equation"]])); - -(*-------------------------Methode-----------------------*) -store_met - (prep_met LinEq.thy "met_rootrateq" [] e_metID - (["RootRatEq"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=Atools_erls, nrls=norm_Rational(*, - asm_rls=[],asm_thm=[]*)}, "empty_script")); -(*-- left 20.10.02 --*) -store_met - (prep_met RootRatEq.thy "met_rootrateq_elim" [] e_metID - (["RootRatEq","elim_rootrat_equation"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) ) | \ - \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="termlessI", - rls'=RooRatEq_erls, - srls=e_rls, - prls=RootRatEq_prls, - calc=[], - crls=RootRatEq_crls, nrls=norm_Rational(*, - asm_rls=[], - asm_thm=[]*)}, - "Script Elim_rootrat_equation (e_::bool) (v_::real) = \ - \(let e_ = ((Try (Rewrite_Set expand_rootbinoms False)) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ - \ (Try (Rewrite_Set make_rooteq False)) @@ \ - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ - \ (Try (Rewrite_Set_Inst [(bdv,v_)] \ - \ rootrat_solve False))) e_ \ - \ in (SubProblem (RootEq_,[univariate,equation], \ - \ [no_met]) [bool_ e_, real_ v_]))" - )); -calclist':= overwritel (!calclist', - [("is_rootRatAddTerm_in", ("RootRatEq.is_rootRatAddTerm_in", - eval_is_rootRatAddTerm_in"")) - ]);(*("", ("", "")),*) -"******* RootRatEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/RootRatEq.thy --- a/src/Tools/isac/IsacKnowledge/RootRatEq.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -(*.c) by Richard Lang, 2003 .*) -(* collecting all knowledge for Root and Rational Equations - created by: rlang - date: 02.10 - changed by: rlang - last change by: rlang - date: 02.11.04 -*) - -(* use"knowledge/RootRatEq.ML"; - use"RootRatEq.ML"; - - use"ROOT.ML"; - cd"knowledge"; - - remove_thy"RootRatEq"; - use_thy"Isac"; - *) - -RootRatEq = RootEq + RatEq + RootRat + - -(*-------------------- consts-----------------------------------------------*) -consts - - is'_rootRatAddTerm'_in :: [real, real] => bool ("_ is'_rootRatAddTerm'_in _") (*RL DA*) - -(*---------scripts--------------------------*) - Elim'_rootrat'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Elim'_rootrat'_equation (_ _ =))// \ - \ (_))" 9) - (*-------------------- rules------------------------------------------------*) -rules - - (* eliminate ratRootTerm *) - rootrat_equation_left_1 - "[|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c ))" - rootrat_equation_left_2 - "[|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c ))" - rootrat_equation_right_2 - "[|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e ))" - rootrat_equation_right_1 - "[|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e ))" - - - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Simplify.ML --- a/src/Tools/isac/IsacKnowledge/Simplify.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -(* simplification of terms - author: Walther Neuper 050912 - (c) due to copyright terms - -use"IsacKnowledge/Simplify.ML"; -use"Simplify.ML"; -*) - - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("Simplify.thy",Simplify.thy)]); - -(** problems **) - -store_pbt - (prep_pbt Simplify.thy "pbl_simp" [] e_pblID - (["simplification"], - [("#Given" ,["term t_"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "Simplify t_", - [])); - -store_pbt - (prep_pbt Simplify.thy "pbl_vereinfache" [] e_pblID - (["vereinfachen"], - [("#Given" ,["term t_"]), - ("#Find" ,["normalform n_"]) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "Vereinfache t_", - [])); - -(** methods **) - -store_met - (prep_met Simplify.thy "met_simp" [] e_metID - (["simplification"], - [("#Given" ,["term t_"]), - ("#Find" ,["normalform n_"]) - ], - {rew_ord'="tless_true", - rls'= e_rls, - calc = [], - srls = e_rls, - prls=e_rls, - crls = e_rls, nrls = e_rls}, - "empty_script" - )); - -(** CAS-command **) - -(*.function for handling the cas-input "Simplify (2*a + 3*a)": - make a model which is already in ptree-internal format.*) -(* val (h,argl) = strip_comb (str2term "Simplify (2*a + 3*a)"); - val (h,argl) = strip_comb ((term_of o the o (parse thy)) - "Simplify (2*a + 3*a)"); - *) -fun argl2dtss t = - [((term_of o the o (parse thy)) "term", t), - ((term_of o the o (parse thy)) "normalform", - [(term_of o the o (parse thy)) "N"]) - ] - | argl2dtss _ = raise error "Simplify.ML: wrong argument for argl2dtss"; - -castab := -overwritel (!castab, - [((term_of o the o (parse thy)) "Simplify", - (("Isac.thy", ["simplification"], ["no_met"]), - argl2dtss)), - ((term_of o the o (parse thy)) "Vereinfache", - (("Isac.thy", ["vereinfachen"], ["no_met"]), - argl2dtss)) - ]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Simplify.thy --- a/src/Tools/isac/IsacKnowledge/Simplify.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -(* simplification of terms - author: Walther Neuper 050912 - (c) due to copyright terms - -remove_thy"Simplify"; -use_thy"~/proto2/isac/src/sml/IsacKnowledge/Simplify"; - -use_thy_only"~/proto2/isac/src/sml/IsacKnowledge/Simplify"; -use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac"; -*) - -Simplify = Atools + - -consts - - (*descriptions in the related problem*) - term :: real => una - normalform :: real => una - - (*the CAS-command*) - Simplify :: "real => real" (*"Simplify (1+2a+3+4a)*) - Vereinfache :: "real => real" (*"Vereinfache (1+2a+3+4a)*) - - (*Script-name*) - SimplifyScript :: "[real, real] => real" - ("((Script SimplifyScript (_ =))// (_))" 9) - - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Test.ML --- a/src/Tools/isac/IsacKnowledge/Test.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1301 +0,0 @@ -(* SML functions for rational arithmetic - WN.22.10.99 - use"../knowledge/Test.ML"; - use"IsacKnowledge/Test.ML"; - use"Test.ML"; - *) - - -(** interface isabelle -- isac **) - -theory' := overwritel (!theory', [("Test.thy",Test.thy)]); - -(** evaluation of numerals and predicates **) - -(*does a term contain a root ?*) -fun eval_root_free (thmid:string) _ (t as (Const(op0,t0) $ arg)) thy = - if strip_thy op0 <> "is'_root'_free" - then raise error ("eval_root_free: wrong "^op0) - else if const_in (strip_thy op0) arg - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, false_as_term))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, true_as_term))) - | eval_root_free _ _ _ _ = NONE; - -(*does a term contain a root ?*) -fun eval_contains_root (thmid:string) _ - (t as (Const("Test.contains'_root",t0) $ arg)) thy = - if member op = (ids_of arg) "sqrt" - then SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, true_as_term))) - else SOME (mk_thmid thmid "" - ((Syntax.string_of_term (thy2ctxt thy)) arg) "", - Trueprop $ (mk_equality (t, false_as_term))) - | eval_contains_root _ _ _ _ = NONE; - -calclist':= overwritel (!calclist', - [("is_root_free", ("Test.is'_root'_free", - eval_root_free"#is_root_free_")), - ("contains_root", ("Test.contains'_root", - eval_contains_root"#contains_root_")) - ]); - -(** term order **) -fun term_order (_:subst) tu = (term_ordI [] tu = LESS); - -(** rule sets **) - -val testerls = - Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI), - erls = e_rls, srls = Erls, - calc = [], - rules = [Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - Thm ("and_commute",num_str and_commute), - Thm ("or_commute",num_str or_commute), - - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Tools.matches",eval_matches ""), - - Calc ("op +",eval_binop "#add_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_")], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -(*.for evaluation of conditions in rewrite rules.*) -(*FIXXXXXXME 10.8.02: handle like _simplify*) -val tval_rls = - Rls{id = "tval_rls", preconds = [], - rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")), - erls=testerls,srls = e_rls, - calc=[], - rules = [Thm ("refl",num_str refl), - Thm ("le_refl",num_str le_refl), - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), - Thm ("not_true",num_str not_true), - Thm ("not_false",num_str not_false), - Thm ("and_true",and_true), - Thm ("and_false",and_false), - Thm ("or_true",or_true), - Thm ("or_false",or_false), - Thm ("and_commute",num_str and_commute), - Thm ("or_commute",num_str or_commute), - - Thm ("real_diff_minus",num_str real_diff_minus), - - Thm ("root_ge0",num_str root_ge0), - Thm ("root_add_ge0",num_str root_add_ge0), - Thm ("root_ge0_1",num_str root_ge0_1), - Thm ("root_ge0_2",num_str root_ge0_2), - - Calc ("Atools.is'_const",eval_const "#is_const_"), - Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_"), - Calc ("Tools.matches",eval_matches ""), - Calc ("Test.contains'_root", - eval_contains_root"#contains_root_"), - - Calc ("op +",eval_binop "#add_"), - Calc ("op *",eval_binop "#mult_"), - Calc ("Root.sqrt",eval_sqrt "#sqrt_"), - Calc ("Atools.pow" ,eval_binop "#power_"), - - Calc ("op <",eval_equ "#less_"), - Calc ("op <=",eval_equ "#less_equal_"), - - Calc ("Atools.ident",eval_ident "#ident_")], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - - -ruleset' := overwritelthy thy (!ruleset', - [("testerls", prep_rls testerls) - ]); - - -(*make () dissappear*) -val rearrange_assoc = - Rls{id = "rearrange_assoc", preconds = [], - rew_ord = ("e_rew_ord",e_rew_ord), - erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*) - rules = - [Thm ("sym_radd_assoc",num_str (radd_assoc RS sym)), - Thm ("sym_rmult_assoc",num_str (rmult_assoc RS sym))], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -val ac_plus_times = - Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order), - erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*) - rules = - [Thm ("radd_commute",radd_commute), - Thm ("radd_left_commute",radd_left_commute), - Thm ("radd_assoc",radd_assoc), - Thm ("rmult_commute",rmult_commute), - Thm ("rmult_left_commute",rmult_left_commute), - Thm ("rmult_assoc",rmult_assoc)], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -(*todo: replace by Rewrite("rnorm_equation_add",num_str rnorm_equation_add)*) -val norm_equation = - Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), - erls = tval_rls, srls = e_rls, calc = [], (*asm_thm=[],*) - rules = [Thm ("rnorm_equation_add",num_str rnorm_equation_add) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -(** rule sets **) - -val STest_simplify = (* vv--- not changed to real by parse*) - "Script STest_simplify (t_::'z) = \ - \(Repeat\ - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - \ (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@ \ - \ (Try (Repeat (Rewrite rdistr_right_assoc False))) @@ \ - \ (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@\ - \ (Try (Repeat (Rewrite rdistr_div_right False))) @@ \ - \ (Try (Repeat (Rewrite rbinom_power_2 False))) @@ \ - - \ (Try (Repeat (Rewrite radd_commute False))) @@ \ - \ (Try (Repeat (Rewrite radd_left_commute False))) @@ \ - \ (Try (Repeat (Rewrite radd_assoc False))) @@ \ - \ (Try (Repeat (Rewrite rmult_commute False))) @@ \ - \ (Try (Repeat (Rewrite rmult_left_commute False))) @@ \ - \ (Try (Repeat (Rewrite rmult_assoc False))) @@ \ - - \ (Try (Repeat (Rewrite radd_real_const_eq False))) @@ \ - \ (Try (Repeat (Rewrite radd_real_const False))) @@ \ - \ (Try (Repeat (Calculate plus))) @@ \ - \ (Try (Repeat (Calculate times))) @@ \ - \ (Try (Repeat (Calculate divide_))) @@\ - \ (Try (Repeat (Calculate power_))) @@ \ - - \ (Try (Repeat (Rewrite rcollect_right False))) @@ \ - \ (Try (Repeat (Rewrite rcollect_one_left False))) @@ \ - \ (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@ \ - \ (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@ \ - - \ (Try (Repeat (Rewrite rshift_nominator False))) @@ \ - \ (Try (Repeat (Rewrite rcancel_den False))) @@ \ - \ (Try (Repeat (Rewrite rroot_square_inv False))) @@ \ - \ (Try (Repeat (Rewrite rroot_times_root False))) @@ \ - \ (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@ \ - \ (Try (Repeat (Rewrite rsqare False))) @@ \ - \ (Try (Repeat (Rewrite power_1 False))) @@ \ - \ (Try (Repeat (Rewrite rtwo_of_the_same False))) @@ \ - \ (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@ \ - - \ (Try (Repeat (Rewrite rmult_1 False))) @@ \ - \ (Try (Repeat (Rewrite rmult_1_right False))) @@ \ - \ (Try (Repeat (Rewrite rmult_0 False))) @@ \ - \ (Try (Repeat (Rewrite rmult_0_right False))) @@ \ - \ (Try (Repeat (Rewrite radd_0 False))) @@ \ - \ (Try (Repeat (Rewrite radd_0_right False)))) \ - \ t_)"; - - -(* expects * distributed over + *) -val Test_simplify = - Rls{id = "Test_simplify", preconds = [], - rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")), - erls = tval_rls, srls = e_rls, - calc=[(*since 040209 filled by prep_rls*)], - (*asm_thm = [],*) - rules = [ - Thm ("real_diff_minus",num_str real_diff_minus), - Thm ("radd_mult_distrib2",num_str radd_mult_distrib2), - Thm ("rdistr_right_assoc",num_str rdistr_right_assoc), - Thm ("rdistr_right_assoc_p",num_str rdistr_right_assoc_p), - Thm ("rdistr_div_right",num_str rdistr_div_right), - Thm ("rbinom_power_2",num_str rbinom_power_2), - - Thm ("radd_commute",num_str radd_commute), - Thm ("radd_left_commute",num_str radd_left_commute), - Thm ("radd_assoc",num_str radd_assoc), - Thm ("rmult_commute",num_str rmult_commute), - Thm ("rmult_left_commute",num_str rmult_left_commute), - Thm ("rmult_assoc",num_str rmult_assoc), - - Thm ("radd_real_const_eq",num_str radd_real_const_eq), - Thm ("radd_real_const",num_str radd_real_const), - (* these 2 rules are invers to distr_div_right wrt. termination. - thus they MUST be done IMMEDIATELY before calc *) - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("HOL.divide", eval_cancel "#divide_"), - Calc ("Atools.pow", eval_binop "#power_"), - - Thm ("rcollect_right",num_str rcollect_right), - Thm ("rcollect_one_left",num_str rcollect_one_left), - Thm ("rcollect_one_left_assoc",num_str rcollect_one_left_assoc), - Thm ("rcollect_one_left_assoc_p",num_str rcollect_one_left_assoc_p), - - Thm ("rshift_nominator",num_str rshift_nominator), - Thm ("rcancel_den",num_str rcancel_den), - Thm ("rroot_square_inv",num_str rroot_square_inv), - Thm ("rroot_times_root",num_str rroot_times_root), - Thm ("rroot_times_root_assoc_p",num_str rroot_times_root_assoc_p), - Thm ("rsqare",num_str rsqare), - Thm ("power_1",num_str power_1), - Thm ("rtwo_of_the_same",num_str rtwo_of_the_same), - Thm ("rtwo_of_the_same_assoc_p",num_str rtwo_of_the_same_assoc_p), - - Thm ("rmult_1",num_str rmult_1), - Thm ("rmult_1_right",num_str rmult_1_right), - Thm ("rmult_0",num_str rmult_0), - Thm ("rmult_0_right",num_str rmult_0_right), - Thm ("radd_0",num_str radd_0), - Thm ("radd_0_right",num_str radd_0_right) - ], - scr = Script ((term_of o the o (parse thy)) "empty_script") - (*since 040209 filled by prep_rls: STest_simplify*) - }:rls; - - - - - -(** rule sets **) - - - -(*isolate the root in a root-equation*) -val isolate_root = - Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), - erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *) - rules = [Thm ("rroot_to_lhs",num_str rroot_to_lhs), - Thm ("rroot_to_lhs_mult",num_str rroot_to_lhs_mult), - Thm ("rroot_to_lhs_add_mult",num_str rroot_to_lhs_add_mult), - Thm ("risolate_root_add",num_str risolate_root_add), - Thm ("risolate_root_mult",num_str risolate_root_mult), - Thm ("risolate_root_div",num_str risolate_root_div) ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - -(*isolate the bound variable in an equation; 'bdv' is a meta-constant*) -val isolate_bdv = - Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), - erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *) - rules = - [Thm ("risolate_bdv_add",num_str risolate_bdv_add), - Thm ("risolate_bdv_mult_add",num_str risolate_bdv_mult_add), - Thm ("risolate_bdv_mult",num_str risolate_bdv_mult), - Thm ("mult_square",num_str mult_square), - Thm ("constant_square",num_str constant_square), - Thm ("constant_mult_square",num_str constant_mult_square) - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - - - - -(* association list for calculate_, calculate - "op +" etc. not usable in scripts *) -val calclist = - [ - (*as Tools.ML*) - ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")), - ("matches",("Tools.matches",eval_matches "#matches_")), - ("lhs" ,("Tools.lhs" ,eval_lhs "")), - (*aus Atools.ML*) - ("PLUS" ,("op +" ,eval_binop "#add_")), - ("TIMES" ,("op *" ,eval_binop "#mult_")), - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), - ("POWER" ,("Atools.pow" ,eval_binop "#power_")), - ("is_const",("Atools.is'_const",eval_const "#is_const_")), - ("le" ,("op <" ,eval_equ "#less_")), - ("leq" ,("op <=" ,eval_equ "#less_equal_")), - ("ident" ,("Atools.ident",eval_ident "#ident_")), - (*von hier (ehem.SqRoot*) - ("sqrt" ,("Root.sqrt" ,eval_sqrt "#sqrt_")), - ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_")), - ("Test.contains_root",("contains'_root", - eval_contains_root"#contains_root_")) - ]; - -ruleset' := overwritelthy thy (!ruleset', - [("Test_simplify", prep_rls Test_simplify), - ("tval_rls", prep_rls tval_rls), - ("isolate_root", prep_rls isolate_root), - ("isolate_bdv", prep_rls isolate_bdv), - ("matches", - prep_rls (append_rls "matches" testerls - [Calc ("Tools.matches",eval_matches "#matches_")])) - ]); - -(** problem types **) -store_pbt - (prep_pbt Test.thy "pbl_test" [] e_pblID - (["test"], - [], - e_rls, NONE, [])); -store_pbt - (prep_pbt Test.thy "pbl_test_equ" [] e_pblID - (["equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - assoc_rls "matches", - SOME "solve (e_::bool, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni" [] e_pblID - (["univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - assoc_rls "matches", - SOME "solve (e_::bool, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_lin" [] e_pblID - (["linear","univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(matches ( v_ = 0) e_) | (matches ( ?b*v_ = 0) e_) |\ - \(matches (?a+v_ = 0) e_) | (matches (?a+?b*v_ = 0) e_) "]), - ("#Find" ,["solutions v_i_"]) - ], - assoc_rls "matches", - SOME "solve (e_::bool, v_)", [["Test","solve_linear"]])); - -(*25.8.01 ------ -store_pbt - (prep_pbt Test.thy - (["Test.thy"], - [("#Given" ,"boolTestGiven g_"), - ("#Find" ,"boolTestFind f_") - ], - [])); - -store_pbt - (prep_pbt Test.thy - (["testeq","Test.thy"], - [("#Given" ,"boolTestGiven g_"), - ("#Find" ,"boolTestFind f_") - ], - [])); - - -val ttt = (term_of o the o (parse Isac.thy)) "(matches ( v_ = 0) e_)"; - - ------ 25.8.01*) - - -(** methods **) -store_met - (prep_met Diff.thy "met_test" [] e_metID - (["Test"], - [], - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, - crls=Atools_erls, nrls=e_rls(*, - asm_rls=[],asm_thm=[]*)}, "empty_script")); -(* -store_met - (prep_met Script.thy - (e_metID,(*empty method*) - [], - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], - asm_rls=[],asm_thm=[]}, - "Undef"));*) -store_met - (prep_met Test.thy "met_test_solvelin" [] e_metID - (["Test","solve_linear"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["matches (?a = ?b) e_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls, - prls=assoc_rls "matches", - calc=[], - crls=tval_rls, nrls=Test_simplify}, - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ =\ - \ Repeat\ - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Rewrite_Set Test_simplify False))) e_\ - \ in [e_::bool])" - ) -(*, prep_met Test.thy (*test for equations*) - (["Test","testeq"]:metID, - [("#Given" ,["boolTestGiven g_"]), - ("#Find" ,["boolTestFind f_"]) - ], - {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[], - asm_thm=[("square_equation_left","")]}, - "Script Testeq (eq_::bool) = \ - \Repeat \ - \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False eq_)); \ - \ e_ = Try (Repeat (Rewrite square_equation_left True e_)); \ - \ e_ = Try (Repeat (Rewrite rmult_0 False e_)) \ - \ in e_) Until (is_root_free e_)" (*deleted*) - ) -, ---------27.4.02*) -); - - - - -ruleset' := overwritelthy thy (!ruleset', - [("norm_equation", prep_rls norm_equation), - ("ac_plus_times", prep_rls ac_plus_times), - ("rearrange_assoc", prep_rls rearrange_assoc) - ]); - - -fun bin_o (Const (op_,(Type ("fun", - [Type (s2,[]),Type ("fun", - [Type (s4,tl4),Type (s5,tl5)])])))) = - if (s2=s4)andalso(s4=s5)then[op_]else[] - | bin_o _ = []; - -fun bin_op (t1 $ t2) = union op = (bin_op t1) (bin_op t2) - | bin_op t = bin_o t; -fun is_bin_op t = ((bin_op t)<>[]); - -fun bin_op_arg1 ((Const (op_,(Type ("fun", - [Type (s2,[]),Type ("fun", - [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = - arg1; -fun bin_op_arg2 ((Const (op_,(Type ("fun", - [Type (s2,[]),Type ("fun", - [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = - arg2; - - -exception NO_EQUATION_TERM; -fun is_equation ((Const ("op =",(Type ("fun", - [Type (_,[]),Type ("fun", - [Type (_,[]),Type ("bool",[])])])))) $ _ $ _) - = true - | is_equation _ = false; -fun equ_lhs ((Const ("op =",(Type ("fun", - [Type (_,[]),Type ("fun", - [Type (_,[]),Type ("bool",[])])])))) $ l $ r) - = l - | equ_lhs _ = raise NO_EQUATION_TERM; -fun equ_rhs ((Const ("op =",(Type ("fun", - [Type (_,[]),Type ("fun", - [Type (_,[]),Type ("bool",[])])])))) $ l $ r) - = r - | equ_rhs _ = raise NO_EQUATION_TERM; - - -fun atom (Const (_,Type (_,[]))) = true - | atom (Free (_,Type (_,[]))) = true - | atom (Var (_,Type (_,[]))) = true -(*| atom (_ (_,"?DUMMY" )) = true ..ML-error *) - | atom((Const ("Bin.integ_of_bin",_)) $ _) = true - | atom _ = false; - -fun varids (Const (s,Type (_,[]))) = [strip_thy s] - | varids (Free (s,Type (_,[]))) = if is_no s then [] - else [strip_thy s] - | varids (Var((s,_),Type (_,[]))) = [strip_thy s] -(*| varids (_ (s,"?DUMMY" )) = ..ML-error *) - | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*) - | varids (Abs(a,T,t)) = union op = [a] (varids t) - | varids (t1 $ t2) = union op = (varids t1) (varids t2) - | varids _ = []; -(*> val t = term_of (hd (parse Diophant.thy "x")); -val t = Free ("x","?DUMMY") : term -> varids t; -val it = [] : string list [] !!! *) - - -fun bin_ops_only ((Const op_) $ t1 $ t2) = - if(is_bin_op (Const op_)) - then(bin_ops_only t1)andalso(bin_ops_only t2) - else false - | bin_ops_only t = - if atom t then true else bin_ops_only t; - -fun polynomial opl t bdVar = (* bdVar TODO *) - subset op = (bin_op t, opl) andalso (bin_ops_only t); - -fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *) - andalso polynomial opl (equ_lhs t) bdVar - andalso polynomial opl (equ_rhs t) bdVar - andalso (subset op = (varids bdVar, varids (equ_lhs t)) orelse - subset op = (varids bdVar, varids (equ_lhs t))); - -(*fun max is = - let fun max_ m [] = m - | max_ m (i::is) = if m max [1,5,3,7,4,2]; -val it = 7 : int *) - -fun max (a,b) = if a < b then b else a; - -fun degree addl mul bdVar t = -let -fun deg _ _ v (Const (s,Type (_,[]))) = if v=strip_thy s then 1 else 0 - | deg _ _ v (Free (s,Type (_,[]))) = if v=strip_thy s then 1 else 0 - | deg _ _ v (Var((s,_),Type (_,[]))) = if v=strip_thy s then 1 else 0 -(*| deg _ _ v (_ (s,"?DUMMY" )) = ..ML-error *) - | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0 - | deg addl mul v (h $ t1 $ t2) = - if subset op = (bin_op h, addl) - then max (deg addl mul v t1 ,deg addl mul v t2) - else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2) -in if polynomial (addl @ [mul]) t bdVar - then SOME (deg addl mul (id_of bdVar) t) else (NONE:int option) -end; -fun degree_ addl mul bdVar t = (* do not export *) - let fun opt (SOME i)= i - | opt NONE = 0 -in opt (degree addl mul bdVar t) end; - - -fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2; - -fun linear_equ addl mul bdVar t = - if is_equation t - then let val degl = degree_ addl mul bdVar (equ_lhs t); - val degr = degree_ addl mul bdVar (equ_rhs t) - in if (degl>0 orelse degr>0)andalso max(degl,degr)<2 - then true else false - end - else false; -(* strip_thy op_ before *) -fun is_div_op (dv,(Const (op_,(Type ("fun", - [Type (s2,[]),Type ("fun", - [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_) - | is_div_op _ = false; - -fun is_denom bdVar div_op t = - let fun is bool[v]dv (Const (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false) - | is bool[v]dv (Free (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false) - | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false) - | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false - | is bool[v]dv (h$n$d) = - if is_div_op(dv,h) - then (is false[v]dv n)orelse(is true[v]dv d) - else (is bool [v]dv n)orelse(is bool[v]dv d) -in is false (varids bdVar) (strip_thy div_op) t end; - - -fun rational t div_op bdVar = - is_denom bdVar div_op t andalso bin_ops_only t; - - - -(** problem types **) - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_plain2" [] e_pblID - (["plain_square","univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\ - \(matches ( ?b*v_ ^^^2 = 0) e_) |\ - \(matches (?a + v_ ^^^2 = 0) e_) |\ - \(matches ( v_ ^^^2 = 0) e_)"]), - ("#Find" ,["solutions v_i_"]) - ], - assoc_rls "matches", - SOME "solve (e_::bool, v_)", [["Test","solve_plain_square"]])); -(* - val e_ = (term_of o the o (parse thy)) "e_::bool"; - val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0"; - val env = [(e_,ve)]; - - val pre = (term_of o the o (parse thy)) - "(matches (a + b*v_ ^^^2 = 0, e_::bool)) |\ - \(matches ( b*v_ ^^^2 = 0, e_::bool)) |\ - \(matches (a + v_ ^^^2 = 0, e_::bool)) |\ - \(matches ( v_ ^^^2 = 0, e_::bool))"; - val prei = subst_atomic env pre; - val cpre = (cterm_of thy) prei; - - val SOME (ct,_) = rewrite_set_ thy false tval_rls cpre; -val ct = "True | False | False | False" : cterm - -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; -val ct = "True" : cterm - -*) - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_poly" [] e_pblID - (["polynomial","univariate","equation","test"], - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), - ("#Where" ,["False"]), - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (e_::bool, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_poly_deg2" [] e_pblID - (["degree_two","polynomial","univariate","equation","test"], - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_poly_deg2_pq" [] e_pblID - (["pq_formula","degree_two","polynomial","univariate","equation","test"], - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_poly_deg2_abc" [] e_pblID - (["abc_formula","degree_two","polynomial","univariate","equation","test"], - [("#Given" ,["equality (a_ * x ^^^2 + b_ * x + c_ = 0)","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (a_ * x ^^^2 + b_ * x + c_ = 0, v_)", [])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_root" [] e_pblID - (["squareroot","univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["contains_root (e_::bool)"]), - ("#Find" ,["solutions v_i_"]) - ], - append_rls "contains_root" e_rls [Calc ("Test.contains'_root", - eval_contains_root "#contains_root_")], - SOME "solve (e_::bool, v_)", [["Test","square_equation"]])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_norm" [] e_pblID - (["normalize","univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,[]), - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (e_::bool, v_)", [["Test","norm_univar_equation"]])); - -store_pbt - (prep_pbt Test.thy "pbl_test_uni_roottest" [] e_pblID - (["sqroot-test","univariate","equation","test"], - [("#Given" ,["equality e_","solveFor v_"]), - (*("#Where" ,["contains_root (e_::bool)"]),*) - ("#Find" ,["solutions v_i_"]) - ], - e_rls, SOME "solve (e_::bool, v_)", [])); - -(* -(#ppc o get_pbt) ["sqroot-test","univariate","equation"]; - *) - - -store_met - (prep_met Test.thy "met_test_sqrt" [] e_metID -(*root-equation, version for tests before 8.01.01*) - (["Test","sqrt-equ-test"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Where" ,["contains_root (e_::bool)"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls =append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root "")], - prls =append_rls "prls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root "")], - calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ ((Rewrite square_equation_left True) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_\ - \ in [e_::bool])" - )); - -store_met - (prep_met Test.thy "met_test_sqrt2" [] e_metID -(*root-equation ... for test-*.sml until 8.01*) - (["Test","squ-equ-test2"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls = append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root"")], - prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ ((Rewrite square_equation_left True) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_;\ - \ (L_::bool list) = Tac subproblem_equation_dummy; \ - \ L_ = Tac solve_equation_dummy \ - \ in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_squ_sub" [] e_metID -(*tests subproblem fixed linear*) - (["Test","squ-equ-test-subpbl1"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], - crls=tval_rls, nrls=Test_simplify}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set norm_equation False)) @@ \ - \ (Try (Rewrite_Set Test_simplify False))) e_; \ - \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ - \ [Test,solve_linear]) [bool_ e_, real_ v_])\ - \in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_squ_sub2" [] e_metID - (*tests subproblem fixed degree 2*) - (["Test","squ-equ-test-subpbl2"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*, - asm_rls=[],asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \ (let e_ = Try (Rewrite_Set norm_equation False) e_; \ - \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ - \ [Test,solve_by_pq_formula]) [bool_ e_, real_ v_])\ - \in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_squ_nonterm" [] e_metID - (*root-equation: see foils..., but notTerminating*) - (["Test","square_equation...notTerminating"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls = append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root"")], - prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ ((Rewrite square_equation_left True) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_;\ - \ (L_::bool list) = \ - \ (SubProblem (Test_,[linear,univariate,equation,test],\ - \ [Test,solve_linear]) [bool_ e_, real_ v_])\ - \in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_eq1" [] e_metID -(*root-equation1:*) - (["Test","square_equation1"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls = append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root"")], - prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ ((Rewrite square_equation_left True) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_;\ - \ (L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ - \ [Test,solve_linear]) [bool_ e_, real_ v_])\ - \ in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_squ2" [] e_metID - (*root-equation2*) - (["Test","square_equation2"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls = append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root"")], - prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ (((Rewrite square_equation_left True) Or \ - \ (Rewrite square_equation_right True)) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_;\ - \ (L_::bool list) = (SubProblem (Test_,[plain_square,univariate,equation,test],\ - \ [Test,solve_plain_square]) [bool_ e_, real_ v_])\ - \ in Check_elementwise L_ {(v_::real). Assumptions})" - )); - -store_met - (prep_met Test.thy "met_test_squeq" [] e_metID - (*root-equation*) - (["Test","square_equation"]:metID, - [("#Given" ,["equality e_","solveFor v_"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls, - srls = append_rls "srls_contains_root" e_rls - [Calc ("Test.contains'_root",eval_contains_root"")], - prls=e_rls,calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[], - asm_thm=[("square_equation_left",""), - ("square_equation_right","")]*)}, - "Script Solve_root_equation (e_::bool) (v_::real) = \ - \(let e_ = \ - \ ((While (contains_root e_) Do\ - \ (((Rewrite square_equation_left True) Or\ - \ (Rewrite square_equation_right True)) @@\ - \ (Try (Rewrite_Set Test_simplify False)) @@\ - \ (Try (Rewrite_Set rearrange_assoc False)) @@\ - \ (Try (Rewrite_Set isolate_root False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))) @@\ - \ (Try (Rewrite_Set norm_equation False)) @@\ - \ (Try (Rewrite_Set Test_simplify False)))\ - \ e_;\ - \ (L_::bool list) = (SubProblem (Test_,[univariate,equation,test],\ - \ [no_met]) [bool_ e_, real_ v_])\ - \ in Check_elementwise L_ {(v_::real). Assumptions})" - ) ); (*#######*) - -store_met - (prep_met Test.thy "met_test_eq_plain" [] e_metID - (*solve_plain_square*) - (["Test","solve_plain_square"]:metID, - [("#Given",["equality e_","solveFor v_"]), - ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\ - \(matches ( ?b*v_ ^^^2 = 0) e_) |\ - \(matches (?a + v_ ^^^2 = 0) e_) |\ - \(matches ( v_ ^^^2 = 0) e_)"]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls, - prls = assoc_rls "matches", - crls=tval_rls, nrls=e_rls(*, - asm_rls=[],asm_thm=[]*)}, - "Script Solve_plain_square (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite_Set isolate_bdv False)) @@ \ - \ (Try (Rewrite_Set Test_simplify False)) @@ \ - \ ((Rewrite square_equality_0 False) Or \ - \ (Rewrite square_equality True)) @@ \ - \ (Try (Rewrite_Set tval_rls False))) e_ \ - \ in ((Or_to_List e_)::bool list))" - )); - -store_met - (prep_met Test.thy "met_test_norm_univ" [] e_metID - (["Test","norm_univar_equation"]:metID, - [("#Given",["equality e_","solveFor v_"]), - ("#Where" ,[]), - ("#Find" ,["solutions v_i_"]) - ], - {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls, - calc=[], - crls=tval_rls, nrls=e_rls(*,asm_rls=[],asm_thm=[]*)}, - "Script Norm_univar_equation (e_::bool) (v_::real) = \ - \ (let e_ = ((Try (Rewrite rnorm_equation_add False)) @@ \ - \ (Try (Rewrite_Set Test_simplify False))) e_ \ - \ in (SubProblem (Test_,[univariate,equation,test], \ - \ [no_met]) [bool_ e_, real_ v_]))" - )); - - - -(*17.9.02 aus SqRoot.ML------------------------------^^^---*) - -(*8.4.03 aus Poly.ML--------------------------------vvv--- - make_polynomial ---> make_poly - ^-- for user ^-- for systest _ONLY_*) - -local (*. for make_polytest .*) - -open Term; (* for type order = EQUAL | LESS | GREATER *) - -fun pr_ord EQUAL = "EQUAL" - | pr_ord LESS = "LESS" - | pr_ord GREATER = "GREATER"; - -fun dest_hd' (Const (a, T)) = (* ~ term.ML *) - (case a of - "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest *) - | _ => (((a, 0), T), 0)) - | dest_hd' (Free (a, T)) = (((a, 0), T), 1) - | dest_hd' (Var v) = (v, 2) - | dest_hd' (Bound i) = ((("", i), dummyT), 3) - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); -(* RL *) -fun get_order_pow (t $ (Free(order,_))) = - (case int_of_str (order) of - SOME d => d - | NONE => 0) - | get_order_pow _ = 0; - -fun size_of_term' (Const(str,_) $ t) = - if "Atools.pow"= str then 1000 + size_of_term' t else 1 + size_of_term' t (*WN*) - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body - | size_of_term' (f$t) = size_of_term' f + size_of_term' t - | size_of_term' _ = 1; - -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) - | term_ord' pr thy (t, u) = - (if pr then - let - val (f, ts) = strip_comb t and (g, us) = strip_comb u; - val _=writeln("t= f@ts= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\""); - val _=writeln("u= g@us= \""^ - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ - (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\""); - val _=writeln("size_of_term(t,u)= ("^ - (string_of_int(size_of_term' t))^", "^ - (string_of_int(size_of_term' u))^")"); - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); - val _=writeln("terms_ord(ts,us) = "^ - ((pr_ord o terms_ord str false)(ts,us))); - val _=writeln("-------"); - in () end - else (); - case int_ord (size_of_term' t, size_of_term' u) of - EQUAL => - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) - | ord => ord) - end - | ord => ord) -and hd_ord (f, g) = (* ~ term.ML *) - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) -and terms_ord str pr (ts, us) = - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); -in - -fun ord_make_polytest (pr:bool) thy (_:subst) tu = - (term_ord' pr thy(***) tu = LESS ); - -end;(*local*) - -rew_ord' := overwritel (!rew_ord', -[("termlessI", termlessI), - ("ord_make_polytest", ord_make_polytest false thy) - ]); - -(*WN060510 this was a preparation for prep_rls ... -val scr_make_polytest = -"Script Expand_binomtest t_ =\ -\(Repeat \ -\((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - -\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \ -\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \ -\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \ -\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \ -\ (Try (Repeat (Rewrite real_add_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \ -\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_)))) \ -\ t_)"; ------------------------------------------------------*) - -val make_polytest = - Rls{id = "make_polytest", preconds = []:term list, rew_ord = ("ord_make_polytest", - ord_make_polytest false Poly.thy), - erls = testerls, srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Thm ("real_diff_minus",num_str real_diff_minus), - (*"a - b = a + (-1) * b"*) - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) - Thm ("real_mult_1",num_str real_mult_1), - (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), - (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left), - (*"0 + z = z"*) - - (*AC-rewriting*) - Thm ("real_mult_commute",num_str real_mult_commute), - (* z * w = w * z *) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) - Thm ("real_mult_assoc",num_str real_mult_assoc), - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) - Thm ("real_add_commute",num_str real_add_commute), - (*z + w = w + z*) - Thm ("real_add_left_commute",num_str real_add_left_commute), - (*x + (y + z) = y + (x + z)*) - Thm ("real_add_assoc",num_str real_add_assoc), - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> - l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], - scr = EmptyScr(*Script ((term_of o the o (parse thy)) - scr_make_polytest)*) - }:rls; -(*WN060510 this was done before 'fun prep_rls' ... -val scr_expand_binomtest = -"Script Expand_binomtest t_ =\ -\(Repeat \ -\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \ -\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \ -\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \ -\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \ - -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_))) @@ \ - -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ - -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ - -\ (Try (Repeat (Calculate plus ))) @@ \ -\ (Try (Repeat (Calculate times ))) @@ \ -\ (Try (Repeat (Calculate power_)))) \ -\ t_)"; -------------------------------------------------------*) - -val expand_binomtest = - Rls{id = "expand_binomtest", preconds = [], - rew_ord = ("termlessI",termlessI), - erls = testerls, srls = Erls, - calc = [("PLUS" , ("op +", eval_binop "#add_")), - ("TIMES" , ("op *", eval_binop "#mult_")), - ("POWER", ("Atools.pow", eval_binop "#power_")) - ], - (*asm_thm = [],*) - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), - (*"(a + b)*(a + b) = ...*) - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) - Thm ("real_minus_binom_times",num_str real_minus_binom_times), - (*"(a - b)*(a - b) = ...*) - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) - (*RL 020915*) - Thm ("real_pp_binom_times",num_str real_pp_binom_times), - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) - Thm ("real_pm_binom_times",num_str real_pm_binom_times), - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) - Thm ("real_mp_binom_times",num_str real_mp_binom_times), - (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*) - Thm ("real_mm_binom_times",num_str real_mm_binom_times), - (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*) - Thm ("realpow_multI",num_str realpow_multI), - (*(a*b)^^^n = a^^^n * b^^^n*) - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), - (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *) - Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3), - (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *) - - - (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) - *) - - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) - Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_"), - (* - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) - Thm ("real_mult_assoc",num_str real_mult_assoc), (**) - Thm ("real_add_commute",num_str real_add_commute), (**) - Thm ("real_add_left_commute",num_str real_add_left_commute), (**) - Thm ("real_add_assoc",num_str real_add_assoc), (**) - *) - - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), - (*"r1 * r1 = r1 ^^^ 2"*) - Thm ("realpow_plus_1",num_str realpow_plus_1), - (*"r * r ^^^ n = r ^^^ (n + 1)"*) - (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), - (*"z1 + z1 = 2 * z1"*)*) - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), - (*"z1 + (z1 + k) = 2 * z1 + k"*) - - Thm ("real_num_collect",num_str real_num_collect), - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) - Thm ("real_one_collect",num_str real_one_collect), - (*"m is_const ==> n + m * n = (1 + m) * n"*) - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) - - Calc ("op +", eval_binop "#add_"), - Calc ("op *", eval_binop "#mult_"), - Calc ("Atools.pow", eval_binop "#power_") - ], - scr = EmptyScr -(*Script ((term_of o the o (parse thy)) scr_expand_binomtest)*) - }:rls; - - -ruleset' := overwritelthy thy (!ruleset', - [("make_polytest", prep_rls make_polytest), - ("expand_binomtest", prep_rls expand_binomtest) - ]); - - - - - - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Test.sml --- a/src/Tools/isac/IsacKnowledge/Test.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -val ttt = (term_of o the o (parse thy)) -"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_"; -val ttt = (term_of o the o (parse thy)) -"(Try (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_)"; - -val ttt = (term_of o the o (parse thy)) - "(Rewrite_Set SqRoot_simplify False) e_ "; -val ttt = (term_of o the o (parseold thy)) - "%e_. (Rewrite_Set SqRoot_simplify False) e_"; -val ttt = (term_of o the o (parseold thy)) - "Repeat (%e_. (Rewrite_Set SqRoot_simplify False)) e_"; - -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \[e_]"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \((%e_. [e_]) e_)"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \((%e_. (let e_ = e_ in [e_])) e_)"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \((%e_. \ - \ (let e_ = ((Rewrite_Set SqRoot_simplify False) e_)\ - \ in [e_]))\ - \ e_)"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \((%ee_. (let e_ = ((Rewrite_Set SqRoot_simplify False) ee_) in [e_])) e_)"; - -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = \ - \ (Repeat ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False)) e_)\ - \ in [e_])"; -(*----*) -val ttt = (term_of o the o (parse thy)) - -(*----*) -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = \ - \ (Repeat\ - \ ((%ee_. (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\ - \ e_)\ - \ e_)\ - \ in [e_])"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = \ - \ (Repeat\ - \ ((%ee_.\ - \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_))\ - \ e_)\ - \ e_)\ - \ in [e_])"; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = \ - \ (Repeat\ - \ ((%ee_.\ - \ (let e_ = ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\ - \ in ((Rewrite_Set SqRoot_simplify False) e_)) )\ - \ e_)\ - \ e_)\ - \ in [e_])"; -atomty ttt; -atomt ttt; - -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ (Rewrite rmult_1 False) g_"; -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ (((Rewrite rmult_1 False)) Or ((Rewrite rmult_0 False))) g_"; -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ ((Repeat (Rewrite rmult_1 False)) Or (Repeat (Rewrite rmult_0 False))) g_"; -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ ((Repeat (Rewrite rmult_1 False)) Or\ - \ (Repeat (Rewrite rmult_0 False))) g_"; -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ ((Repeat (Rewrite rmult_1 False)) Or\ - \ (Repeat (Rewrite rmult_0 False)) Or\ - \ (Repeat (Rewrite rmult_0 False))) g_"; -val ttt = (term_of o the o (parse thy)) - "Script Testterm (g_::real) = \ - \Repeat\ - \ ((Try Repeat (Rewrite rmult_1 False)) Or\ - \ (Try Repeat (Rewrite rmult_0 False)) Or\ - \ (Try Repeat (Rewrite rmult_0 False))) g_"; - - - - - - - - - - - - - -(*################### 29.4.02: Rewrite o Rewrite o ...###############*) -(*################### 29.4.02: Rewrite o Rewrite o ...###############*) -(*################### 29.4.02: Rewrite o Rewrite o ...###############*) - - - -atomt ttt; -val ttt = (term_of o the o (parse thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = \ - \ ((Repeat\ - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Rewrite_Set SqRoot_simplify False)))) e_)\ - \ in [e_])"; -atomty ttt; - - -val ttt = (term_of o the o (parse thy)) -"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@ yyy"; -atomty ttt; -val ttt = (term_of o the o (parse thy)) - "(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Rewrite_Set SqRoot_simplify False)"; -atomty ttt; -val ttt = (term_of o the o (parse thy)) - "(Repeat\ - \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Rewrite_Set SqRoot_simplify False))) e_"; -atomty ttt; -val ttt = (term_of o the o (parseold thy)) -"(let e_ = Repeat xxx e_ in [e_::bool])"; -atomty ttt; -val ttt = (term_of o the o (parseold thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ = Repeat (xxx) e_ in [e_::bool])"; -atomty ttt; -val ttt = (term_of o the o (parseold thy)) - "Script Solve_linear (e_::bool) (v_::real)= \ - \(let e_ =\ - \ Repeat\ - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ - \ (Rewrite_Set SqRoot_simplify False))) e_\ - \ in [e_::bool])" -; -atomty ttt; - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Test.thy --- a/src/Tools/isac/IsacKnowledge/Test.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,169 +0,0 @@ -(* use_thy"IsacKnowledge/Test"; - *) - -Test = Atools + Rational + Root + Poly + - -consts - -(*"cancel":: [real, real] => real (infixl "'/'/'/" 70) ...divide 2002*) - - Expand'_binomtest - :: "['y, \ - \ 'y] => 'y" - ("((Script Expand'_binomtest (_ =))// \ - \ (_))" 9) - - Solve'_univar'_err - :: "[bool,real,bool, \ - \ bool list] => bool list" - ("((Script Solve'_univar'_err (_ _ _ =))// \ - \ (_))" 9) - - Solve'_linear - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_linear (_ _ =))// \ - \ (_))" 9) - -(*17.9.02 aus SqRoot.thy------------------------------vvv---*) - - "is'_root'_free" :: 'a => bool ("is'_root'_free _" 10) - "contains'_root" :: 'a => bool ("contains'_root _" 10) - - Solve'_root'_equation - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_root'_equation (_ _ =))// \ - \ (_))" 9) - - Solve'_plain'_square - :: "[bool,real, \ - \ bool list] => bool list" - ("((Script Solve'_plain'_square (_ _ =))// \ - \ (_))" 9) - - Norm'_univar'_equation - :: "[bool,real, \ - \ bool] => bool" - ("((Script Norm'_univar'_equation (_ _ =))// \ - \ (_))" 9) - - STest'_simplify - :: "['z, \ - \ 'z] => 'z" - ("((Script STest'_simplify (_ =))// \ - \ (_))" 9) - -(*17.9.02 aus SqRoot.thy------------------------------^^^---*) - -rules (*stated as axioms, todo: prove as theorems*) - - radd_mult_distrib2 "(k::real) * (m + n) = k * m + k * n" - rdistr_right_assoc "(k::real) + l * n + m * n = k + (l + m) * n" - rdistr_right_assoc_p "l * n + (m * n + (k::real)) = (l + m) * n + k" - rdistr_div_right "((k::real) + l) / n = k / n + l / n" - rcollect_right - "[| l is_const; m is_const |] ==> (l::real)*n + m*n = (l + m) * n" - rcollect_one_left - "m is_const ==> (n::real) + m * n = (1 + m) * n" - rcollect_one_left_assoc - "m is_const ==> (k::real) + n + m * n = k + (1 + m) * n" - rcollect_one_left_assoc_p - "m is_const ==> n + (m * n + (k::real)) = (1 + m) * n + k" - - rtwo_of_the_same "a + a = 2 * a" - rtwo_of_the_same_assoc "(x + a) + a = x + 2 * a" - rtwo_of_the_same_assoc_p"a + (a + x) = 2 * a + x" - - rcancel_den "not(a=0) ==> a * (b / a) = b" - rcancel_const "[| a is_const; b is_const |] ==> a*(x/b) = a/b*x" - rshift_nominator "(a::real) * b / c = a / c * b" - - exp_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)" - rsqare "(a::real) * a = a ^^^ 2" - power_1 "(a::real) ^^^ 1 = a" - rbinom_power_2 "((a::real) + b)^^^ 2 = a^^^ 2 + 2*a*b + b^^^ 2" - - rmult_1 "1 * k = (k::real)" - rmult_1_right "k * 1 = (k::real)" - rmult_0 "0 * k = (0::real)" - rmult_0_right "k * 0 = (0::real)" - radd_0 "0 + k = (k::real)" - radd_0_right "k + 0 = (k::real)" - - radd_real_const_eq - "[| a is_const; c is_const; d is_const |] ==> a/d + c/d = (a+c)/(d::real)" - radd_real_const - "[| a is_const; b is_const; c is_const; d is_const |] ==> a/b + c/d = (a*d + b*c)/(b*(d::real))" - -(*for AC-operators*) - radd_commute "(m::real) + (n::real) = n + m" - radd_left_commute "(x::real) + (y + z) = y + (x + z)" - radd_assoc "(m::real) + n + k = m + (n + k)" - rmult_commute "(m::real) * n = n * m" - rmult_left_commute "(x::real) * (y * z) = y * (x * z)" - rmult_assoc "(m::real) * n * k = m * (n * k)" - -(*for equations: 'bdv' is a meta-constant*) - risolate_bdv_add "((k::real) + bdv = m) = (bdv = m + (-1)*k)" - risolate_bdv_mult_add "((k::real) + n*bdv = m) = (n*bdv = m + (-1)*k)" - risolate_bdv_mult "((n::real) * bdv = m) = (bdv = m / n)" - - rnorm_equation_add - "~(b =!= 0) ==> (a = b) = (a + (-1)*b = 0)" - -(*17.9.02 aus SqRoot.thy------------------------------vvv---*) - root_ge0 "0 <= a ==> 0 <= sqrt a" - (*should be dropped with better simplification in eval_rls ...*) - root_add_ge0 - "[| 0 <= a; 0 <= b |] ==> (0 <= sqrt a + sqrt b) = True" - root_ge0_1 - "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= a * sqrt b + sqrt c) = True" - root_ge0_2 - "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= sqrt a + b * sqrt c) = True" - - - rroot_square_inv "(sqrt a)^^^ 2 = a" - rroot_times_root "sqrt a * sqrt b = sqrt(a*b)" - rroot_times_root_assoc "(a * sqrt b) * sqrt c = a * sqrt(b*c)" - rroot_times_root_assoc_p "sqrt b * (sqrt c * a)= sqrt(b*c) * a" - - -(*for root-equations*) - square_equation_left - "[| 0 <= a; 0 <= b |] ==> (((sqrt a)=b)=(a=(b^^^ 2)))" - square_equation_right - "[| 0 <= a; 0 <= b |] ==> ((a=(sqrt b))=((a^^^ 2)=b))" - (*causes frequently non-termination:*) - square_equation - "[| 0 <= a; 0 <= b |] ==> ((a=b)=((a^^^ 2)=b^^^ 2))" - - risolate_root_add "(a+ sqrt c = d) = ( sqrt c = d + (-1)*a)" - risolate_root_mult "(a+b*sqrt c = d) = (b*sqrt c = d + (-1)*a)" - risolate_root_div "(a * sqrt c = d) = ( sqrt c = d / a)" - -(*for polynomial equations of degree 2; linear case in RatArith*) - mult_square "(a*bdv^^^2 = b) = (bdv^^^2 = b / a)" - constant_square "(a + bdv^^^2 = b) = (bdv^^^2 = b + -1*a)" - constant_mult_square "(a + b*bdv^^^2 = c) = (b*bdv^^^2 = c + -1*a)" - - square_equality - "0 <= a ==> (x^^^2 = a) = ((x=sqrt a) | (x=-1*sqrt a))" - square_equality_0 - "(x^^^2 = 0) = (x = 0)" - -(*isolate root on the LEFT hand side of the equation - otherwise shuffling from left to right would not terminate*) - - rroot_to_lhs - "is_root_free a ==> (a = sqrt b) = (a + (-1)*sqrt b = 0)" - rroot_to_lhs_mult - "is_root_free a ==> (a = c*sqrt b) = (a + (-1)*c*sqrt b = 0)" - rroot_to_lhs_add_mult - "is_root_free a ==> (a = d+c*sqrt b) = (a + (-1)*c*sqrt b = d)" - - -(*17.9.02 aus SqRoot.thy------------------------------^^^---*) - - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Trig.thy --- a/src/Tools/isac/IsacKnowledge/Trig.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ - -Trig = Real + - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Typefix.thy --- a/src/Tools/isac/IsacKnowledge/Typefix.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,68 +0,0 @@ -(* Title: fixed type for _RE_parsing of strings from frontend - Author: Walther Neuper - 9911xx - (c) due to copyright terms - with hints from Markus Wenzel - *) - -theory Typefix imports "../Scripts/Script" -uses ("../Scripts/scrtools.sml") -("../ME/mstools.sml") ("../ME/ctree.sml") ("../ME/ptyps.sml") -("../ME/generate.sml") ("../ME/calchead.sml") ("../ME/appl.sml") -("../ME/rewtools.sml") ("../ME/script.sml") ("../ME/solve.sml") -("../ME/inform.sml") ("../ME/mathengine.sml") -("../xmlsrc/mathml.sml") ("../xmlsrc/datatypes.sml") -("../xmlsrc/pbl-met-hierarchy.sml") ("../xmlsrc/thy-hierarchy.sml") -("../xmlsrc/interface-xml.sml") ("../FE-interface/messages.sml") -("../FE-interface/states.sml") ("../FE-interface/interface.sml") -("../print_exn_G.sml") -begin -use "../Scripts/scrtools.sml" - -use "../ME/mstools.sml" -use "../ME/ctree.sml" -use "../ME/ptyps.sml" -use "../ME/generate.sml" -use "../ME/calchead.sml" -use "../ME/appl.sml" -use "../ME/rewtools.sml" -use "../ME/script.sml" -use "../ME/solve.sml" -use "../ME/inform.sml" -use "../ME/mathengine.sml" - -use "../xmlsrc/mathml.sml" -use "../xmlsrc/datatypes.sml" -use "../xmlsrc/pbl-met-hierarchy.sml" -use "../xmlsrc/thy-hierarchy.sml" -use "../xmlsrc/interface-xml.sml" - -use "../FE-interface/messages.sml" -use "../FE-interface/states.sml" -use "../FE-interface/interface.sml" - -use "../print_exn_G.sml" - -syntax - - "_plus" :: 'a - "_minus" :: 'a - "_umin" :: 'a - "_times" :: 'a - -translations - - "op +" => "_plus :: [real, real] => real" (*infixl 65 *) - "op -" => "_minus :: [real, real] => real" (*infixl 65 *) - "uminus"=> "_umin :: [real] => real" (*"- _" [80] 80*) - "op *" => "_times :: [real, real] => real" (*infixl 70 *) - -ML {* -val parse_translation = - [("_plus", curry Term.list_comb (Syntax.const "op +")), - ("_minus", curry Term.list_comb (Syntax.const "op -")), - ("_umin", curry Term.list_comb (Syntax.const "uminus")), - ("_times", curry Term.list_comb (Syntax.const "op *"))]; -*} - -end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/IsacKnowledge/Vect.thy --- a/src/Tools/isac/IsacKnowledge/Vect.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -Vect = Real + -(*-------------------- consts ------------------------------------------------*) - -(*-------------------- rules -------------------------------------------------*) -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Isac_Mathengine.thy --- a/src/Tools/isac/Isac_Mathengine.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,102 +0,0 @@ -(* Title: ~~~/isac/Isac_Mathengine.thy - Author: Walther Neuper, TU Graz - -$ cd /usr/local/Isabelle2009-1/src/Tools/isac -$ /usr/local/isabisac/bin/isabelle emacs Isac_Mathengine.thy & -$ /usr/local/isabisac/bin/isabelle jedit Isac_Mathengine.thy & - -12345678901234567890123456789012345678901234567890123456789012345678901234567890 - 10 20 30 40 50 60 70 80 -*) - -header {* Loading the isac mathengine *} - -theory Isac_Mathengine -(*imports Complex_Main*) -imports Complex_Main "Scripts/Script" (*ListG, Tools, Script*) -begin - -ML {* -writeln "**** build the isac kernel = math-engine + IsacKnowledge "; -writeln "**** build the math-engine ******************************" *} - -ML {* Toplevel.debug := true; *} -use "library.sml" -use "calcelems.sml" -ML {* check_guhs_unique := true *} - -use "Scripts/term_G.sml" -use "Scripts/calculate.sml" -use "Scripts/rewrite.sml" -use_thy"Scripts/Script" -use "Scripts/scrtools.sml" - -use "ME/mstools.sml" -use "ME/ctree.sml" -use "ME/ptyps.sml" -use "ME/generate.sml" -use "ME/calchead.sml" -use "ME/appl.sml" -use "ME/rewtools.sml" -use "ME/script.sml" -use "ME/solve.sml" -use "ME/inform.sml" -use "ME/mathengine.sml" - -use "xmlsrc/mathml.sml" -use "xmlsrc/datatypes.sml" -use "xmlsrc/pbl-met-hierarchy.sml" -use "xmlsrc/thy-hierarchy.sml" -use "xmlsrc/interface-xml.sml" - -use "FE-interface/messages.sml" -use "FE-interface/states.sml" -use "FE-interface/interface.sml" - -use "print_exn_G.sml" -text "**** build math-engine complete *************************" - -ML {* writeln "**** build the IsacKnowledge ****************************" *} -use_thy"IsacKnowledge/Typefix" -use_thy"IsacKnowledge/Descript" - -ML {* - -111; -*} - -use_thy"IsacKnowledge/Atools" - - -ML {* -val str = "1234567890"; -*} - -(* -use_thy"IsacKnowledge/Simplify" -use_thy"IsacKnowledge/Poly" -use_thy"IsacKnowledge/Rational" -use_thy"IsacKnowledge/PolyMinus" -use_thy"IsacKnowledge/Equation" -use_thy"IsacKnowledge/LinEq" -use_thy"IsacKnowledge/Root" -use_thy"IsacKnowledge/RootEq" -use_thy"IsacKnowledge/RatEq" -use_thy"IsacKnowledge/RootRat" -use_thy"IsacKnowledge/RootRatEq" -use_thy"IsacKnowledge/PolyEq" -use_thy"IsacKnowledge/Vect" -use_thy"IsacKnowledge/Calculus" -use_thy"IsacKnowledge/Trig" -use_thy"IsacKnowledge/LogExp" -use_thy"IsacKnowledge/Diff" -use_thy"IsacKnowledge/DiffApp" -use_thy"IsacKnowledge/Integrate" -use_thy"IsacKnowledge/EqSystem" -use_thy"IsacKnowledge/Biegelinie" -use_thy"IsacKnowledge/AlgEin" -use_thy"IsacKnowledge/Test" -use_thy"IsacKnowledge/Isac" -*) -end - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/AlgEin.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/AlgEin.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,141 @@ +(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt + author: Walther Neuper 2007 + (c) due to copyright terms + +use"Knowledge/AlgEin.ML"; +use"AlgEin.ML"; + +remove_thy"Typefix"; +remove_thy"AlgEin"; +use_thy"Knowledge/Isac"; +*) + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("AlgEin.thy",AlgEin.thy)]); + +(** problems **) + +store_pbt + (prep_pbt AlgEin.thy "pbl_algein" [] e_pblID + (["Berechnung"], [], e_rls, NONE, + [])); +(* WN070405 +store_pbt + (prep_pbt AlgEin.thy "pbl_algein_num" [] e_pblID + (["numerische", "Berechnung"], + [("#Given" ,["KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]), + ("#Find" ,["GesamtLaenge l_"]) + ], + append_rls "e_rls" e_rls [], + NONE, + [])); +*) +store_pbt + (prep_pbt AlgEin.thy "pbl_algein_numsym" [] e_pblID + (["numerischSymbolische", "Berechnung"], + [("#Given" ,["KantenLaenge k_","Querschnitt q__"(*q_ in Biegelinie.thy*), + "KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]), + ("#Find" ,["GesamtLaenge l_"]) + ], + e_rls, + NONE, + [["Berechnung","erstNumerisch"],["Berechnung","erstSymbolisch"]])); + +(* show_ptyps(); + *) + + +(** methods **) + +store_met + (prep_met AlgEin.thy "met_algein" [] e_metID + (["Berechnung"], + [], + {rew_ord'="tless_true", rls'= Erls, calc = [], + srls = Erls, prls = Erls, + crls =Erls , nrls = Erls}, +"empty_script" +)); + +store_met + (prep_met AlgEin.thy "met_algein_numsym" [] e_metID + (["Berechnung","erstNumerisch"], + [], + {rew_ord'="tless_true", rls'= Erls, calc = [], + srls = Erls, prls = Erls, + crls =Erls , nrls = Erls}, +"empty_script" +)); + +store_met + (prep_met AlgEin.thy "met_algein_numsym" [] e_metID + (["Berechnung","erstNumerisch"], + [("#Given" ,["KantenLaenge k_","Querschnitt q__", + "KantenUnten u_", "KantenSenkrecht s_", + "KantenOben o_"]), + ("#Find" ,["GesamtLaenge l_"]) + ], + {rew_ord'="tless_true", rls'= e_rls, calc = [], + srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls + [Calc ("Atools.boollist2sum", + eval_boollist2sum "")], + prls = e_rls, crls =e_rls , nrls = norm_Rational}, +"Script RechnenSymbolScript (k_::bool) (q__::bool) \ +\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\ +\ (let t_ = Take (l_ = oben + senkrecht + unten); \ +\ sum_ = boollist2sum o_;\ +\ t_ = Substitute [oben = sum_] t_;\ +\ t_ = Substitute o_ t_;\ +\ t_ = Substitute [k_, q__] t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ +\ sum_ = boollist2sum s_;\ +\ t_ = Substitute [senkrecht = sum_] t_;\ +\ t_ = Substitute s_ t_;\ +\ t_ = Substitute [k_, q__] t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ +\ sum_ = boollist2sum u_;\ +\ t_ = Substitute [unten = sum_] t_;\ +\ t_ = Substitute u_ t_;\ +\ t_ = Substitute [k_, q__] t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_\ +\ in (Try (Rewrite_Set norm_Poly False)) t_)" +)); + +store_met + (prep_met AlgEin.thy "met_algein_symnum" [] e_metID + (["Berechnung","erstSymbolisch"], + [("#Given" ,["KantenLaenge k_","Querschnitt q__", + "KantenUnten u_", "KantenSenkrecht s_", + "KantenOben o_"]), + ("#Find" ,["GesamtLaenge l_"]) + ], + {rew_ord'="tless_true", rls'= e_rls, calc = [], + srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls + [Calc ("Atools.boollist2sum", + eval_boollist2sum "")], + prls = e_rls, + crls =e_rls , nrls = norm_Rational}, +"Script RechnenSymbolScript (k_::bool) (q__::bool) \ +\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\ +\ (let t_ = Take (l_ = oben + senkrecht + unten); \ +\ sum_ = boollist2sum o_;\ +\ t_ = Substitute [oben = sum_] t_;\ +\ t_ = Substitute o_ t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ +\ sum_ = boollist2sum s_;\ +\ t_ = Substitute [senkrecht = sum_] t_;\ +\ t_ = Substitute s_ t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ +\ sum_ = boollist2sum u_;\ +\ t_ = Substitute [unten = sum_] t_;\ +\ t_ = Substitute u_ t_;\ +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\ +\ t_ = Substitute [k_, q__] t_\ +\ in (Try (Rewrite_Set norm_Poly False)) t_)" +)); + +(* show_mets(); + *) +(* use"Knowledge/AlgEin.ML"; + *) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/AlgEin.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/AlgEin.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,37 @@ +(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt + author: Walther Neuper 2007 + (c) due to copyright terms + +remove_thy"AlgEin"; +use_thy"Knowledge/AlgEin"; +use_thy_only"Knowledge/AlgEin"; + +remove_thy"AlgEin"; +use_thy"Knowledge/Isac"; +*) + +AlgEin = Rational + +(*Poly + ..shouldbe sufficient, but norm_Poly *) + +consts + + (*new Descriptions in the related problems*) + KantenUnten :: bool list => una + KantenSenkrecht :: bool list => una + KantenOben :: bool list => una + KantenLaenge :: bool => una + Querschnitt :: bool => una + GesamtLaenge :: real => una + + (*Script-names*) + RechnenSymbolScript :: "[bool,bool,bool list,bool list,bool list,real, + bool] => bool" + ("((Script RechnenSymbolScript (_ _ _ _ _ _ =))// (_))" 9) + +(* +rules + (*this axiom creates a contradictory formal system, + see problem TOOODO *) +*) + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Atools.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Atools.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,645 @@ +(* tools for arithmetic + WN.8.3.01 + use"../Knowledge/Atools.ML"; + use"Knowledge/Atools.ML"; + use"Atools.ML"; + *) + +(* +copy from doc/math-eng.tex WN.28.3.03 +WN071228 extended + +\section{Coding standards} + +%WN071228 extended -----vvv +\subsection{Identifiers} +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). + +This are the preliminary rules for naming identifiers> +\begin{description} +\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}. +\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}. +\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~! +\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}. +\item [???] ??? +\item [???] ??? +\end{description} +%WN071228 extended -----^^^ + + +\subsection{Rule sets} +The actual version of the coding standards for rulesets is in {\tt /Knowledge/Atools.ML where it can be viewed using the knowledge browsers. + +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. +\begin{description} + +\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). + +\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. + +\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. +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). + +\end{description} +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. +The following rulesets are used for internal purposes and usually invisible to the (naive) user: +\begin{description} + +\item [*\_erls] +\item [*\_prls] +\item [*\_srls] + +\end{description} +{\tt append_rls, merge_rls, remove_rls} +*) + +"******* Atools.ML begin *******"; +theory' := overwritel (!theory', [("Atools.thy",Atools.thy)]); + +(** evaluation of numerals and special predicates on the meta-level **) +(*-------------------------functions---------------------*) +local (* rlang 09.02 *) + (*.a 'c is coefficient of v' if v does occur in c.*) + fun coeff_in v c = member op = (vars c) v; +in + fun occurs_in v t = coeff_in v t; +end; + +(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*) +fun eval_occurs_in _ "Atools.occurs'_in" + (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ = + ((*writeln("@@@ eval_occurs_in: v= "^(term2str v)); + writeln("@@@ eval_occurs_in: t= "^(term2str t));*) + if occurs_in v t + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const)))) + | eval_occurs_in _ _ _ _ = NONE; + +(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*) +fun some_occur_in vs t = + let fun occurs_in' a b = occurs_in b a + in foldl or_ (false, map (occurs_in' t) vs) end; + +(*("some_occur_in", ("Atools.some'_occur'_in", + eval_some_occur_in "#eval_some_occur_in_"))*) +fun eval_some_occur_in _ "Atools.some'_occur'_in" + (p as (Const ("Atools.some'_occur'_in",_) + $ vs $ t)) _ = + if some_occur_in (isalist2list vs) t + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_some_occur_in _ _ _ _ = NONE; + + + + +(*evaluate 'is_atom'*) +(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*) +fun eval_is_atom (thmid:string) "Atools.is'_atom" + (t as (Const(op0,_) $ arg)) thy = + (case arg of + Free (n,_) => SOME (mk_thmid thmid op0 n "", + Trueprop $ (mk_equality (t, true_as_term))) + | _ => SOME (mk_thmid thmid op0 "" "", + Trueprop $ (mk_equality (t, false_as_term)))) + | eval_is_atom _ _ _ _ = NONE; + +(*evaluate 'is_even'*) +fun even i = (i div 2) * 2 = i; +(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*) +fun eval_is_even (thmid:string) "Atools.is'_even" + (t as (Const(op0,_) $ arg)) thy = + (case arg of + Free (n,_) => + (case int_of_str n of + SOME i => + if even i then SOME (mk_thmid thmid op0 n "", + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 "" "", + Trueprop $ (mk_equality (t, false_as_term))) + | _ => NONE) + | _ => NONE) + | eval_is_even _ _ _ _ = NONE; + +(*evaluate 'is_const'*) +(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*) +fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*) + (t as (Const(op0,t0) $ arg)) (thy:theory) = + (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*) + (case arg of + Const (n1,_) => + SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, false_as_term))) + | Free (n1,_) => + if is_numeral n1 + then SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, false_as_term))) + | Const ("Float.Float",_) => + SOME (mk_thmid thmid op0 (term2str arg) "", + Trueprop $ (mk_equality (t, true_as_term))) + | _ => (*NONE*) + SOME (mk_thmid thmid op0 (term2str arg) "", + Trueprop $ (mk_equality (t, false_as_term)))) + | eval_const _ _ _ _ = NONE; + +(*. evaluate binary, associative, commutative operators: *,+,^ .*) +(*("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*) + +(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) = + ("xxxxxx",op_,t,thy); + *) +fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) = + thmid ^ "Float ((" ^ + (string_of_int v11)^","^(string_of_int v12)^"), ("^ + (string_of_int p11)^","^(string_of_int p12)^")) __ (("^ + (string_of_int v21)^","^(string_of_int v22)^"), ("^ + (string_of_int p21)^","^(string_of_int p22)^"))"; + +(*.convert int and float to internal floatingpoint prepresentation.*) +fun numeral (Free (str, T)) = + (case int_of_str str of + SOME i => SOME ((i, 0), (0, 0)) + | NONE => NONE) + | numeral (Const ("Float.Float", _) $ + (Const ("Pair", _) $ + (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $ + (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))= + (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of + (SOME v1', SOME v2', SOME p1', SOME p2') => + SOME ((v1', v2'), (p1', p2')) + | _ => NONE) + | numeral _ = NONE; + +(*.evaluate binary associative operations.*) +fun eval_binop (thmid:string) (op_:string) + (t as ( Const(op0,t0) $ + (Const(op0',t0') $ v $ t1) $ t2)) + thy = (*binary . (v.n1).n2*) + if op0 = op0' then + case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + let val (T1,T2,Trange) = dest_binop_typ t0 + val res = calc (if op0 = "op -" then "op +" else op0) n1 n2 + (*WN071229 "HOL.divide" never tried*) + val rhs = var_op_float v op_ t0 T1 res + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE + else NONE + | eval_binop (thmid:string) (op_:string) + (t as + (Const (op0, t0) $ t1 $ + (Const (op0', t0') $ t2 $ v))) + thy = (*binary . n1.(n2.v)*) + if op0 = op0' then + case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + if op0 = "op -" then NONE else + let val (T1,T2,Trange) = dest_binop_typ t0 + val res = calc op0 n1 n2 + val rhs = float_op_var v op_ t0 T1 res + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE + else NONE + + | eval_binop (thmid:string) (op_:string) + (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*) + (case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + let val (T1,T2,Trange) = dest_binop_typ t0; + val res = calc op0 n1 n2; + val rhs = term_of_float Trange res; + val prop = Trueprop $ (mk_equality (t, rhs)); + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE) + | eval_binop _ _ _ _ = NONE; +(* +> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy; +> term2str t; +val it = "-1 + 2 = 1" +> val t = str2term "-1 * (-1 * a)"; +> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy; +> term2str t; +val it = "-1 * (-1 * a) = 1 * a"*) + + + +(*.evaluate < and <= for numerals.*) +(*("le" ,("op <" ,eval_equ "#less_")), + ("leq" ,("op <=" ,eval_equ "#less_equal_"))*) +fun eval_equ (thmid:string) (op_:string) (t as + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = + (case (int_of_str n1, int_of_str n2) of + (SOME n1', SOME n2') => + if calc_equ (strip_thy op0) (n1', n2') + then SOME (mk_thmid thmid op0 n1 n2, + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 n1 n2, + Trueprop $ (mk_equality (t, false_as_term))) + | _ => NONE) + + | eval_equ _ _ _ _ = NONE; + + +(*evaluate identity +> reflI; +val it = "(?t = ?t) = True" +> val t = str2term "x = 0"; +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; + +> val t = str2term "1 = 0"; +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; +----------- thus needs Calc ! +> val t = str2term "0 = 0"; +> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t; +> term2str t'; +val it = "True" + +val t = str2term "Not (x = 0)"; +atomt t; term2str t; +*** ------------- +*** Const ( Not) +*** . Const ( op =) +*** . . Free ( x, ) +*** . . Free ( 0, ) +val it = "x ~= 0" : string*) + +(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of + the arguments: thus special handling by 'fun eval_binop'*) +(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*) +fun eval_ident (thmid:string) "Atools.ident" (t as + (Const (op0,t0) $ t1 $ t2 )) thy = + if t1 = t2 + then SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, false_as_term))) + | eval_ident _ _ _ _ = NONE; +(* TODO +> val t = str2term "x =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(x)_(0)" : string +val it = "(x =!= 0) = False" : string +> val t = str2term "1 =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(1)_(0)" : string +val it = "(1 =!= 0) = False" : string +> val t = str2term "0 =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(0)_(0)" : string +val it = "(0 =!= 0) = True" : string +*) + +(*.evaluate identity of terms, which stay ready for evaluation in turn; + thus returns False only for atoms.*) +(*("equal" ,("op =",eval_equal "#equal_")):calc*) +fun eval_equal (thmid:string) "op =" (t as + (Const (op0,t0) $ t1 $ t2 )) thy = + if t1 = t2 + then ((*writeln"... eval_equal: t1 = t2 --> True";*) + SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, true_as_term))) + ) + else (case (is_atom t1, is_atom t2) of + (true, true) => + ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*) + SOME (mk_thmid thmid op0 + ("("^(term2str t1)^")") ("("^(term2str t2)^")"), + Trueprop $ (mk_equality (t, false_as_term))) + ) + | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*) + NONE)) + | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit"; + NONE); +(* +val t = str2term "x ~= 0"; +val NONE = eval_equal "equal_" "b" t thy; + + +> val t = str2term "(x + 1) = (x + 1)"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(x + 1)_(x + 1)" : string +val it = "(x + 1 = x + 1) = True" : string +> val t = str2term "x = 0"; +> val NONE = eval_equal "equal_" "b" t thy; + +> val t = str2term "1 = 0"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(1)_(0)" : string +val it = "(1 = 0) = False" : string +> val t = str2term "0 = 0"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(0)_(0)" : string +val it = "(0 = 0) = True" : string +*) + + +(** evaluation on the metalevel **) + +(*. evaluate HOL.divide .*) +(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*) +fun eval_cancel (thmid:string) "HOL.divide" (t as + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = + (case (int_of_str n1, int_of_str n2) of + (SOME n1', SOME n2') => + let + val sg = sign2 n1' n2'; + val (T1,T2,Trange) = dest_binop_typ t0; + val gcd' = gcd (abs n1') (abs n2'); + in if gcd' = abs n2' + then let val rhs = term_of_num Trange (sg * (abs n1') div gcd') + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid thmid op0 n1 n2, prop) end + else if 0 < n2' andalso gcd' = 1 then NONE + else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd') + ((abs n2') div gcd') + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid thmid op0 n1 n2, prop) end + end + | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE)) + + | eval_cancel _ _ _ _ = NONE; + +(*. get the argument from a function-definition.*) +(*("argument_in" ,("Atools.argument'_in", + eval_argument_in "Atools.argument'_in"))*) +fun eval_argument_in _ "Atools.argument'_in" + (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ = + if is_Free arg (*could be something to be simplified before*) + then SOME (term2str t ^ " = " ^ term2str arg, + Trueprop $ (mk_equality (t, arg))) + else NONE + | eval_argument_in _ _ _ _ = NONE; + +(*.check if the function-identifier of the first argument matches + the function-identifier of the lhs of the second argument.*) +(*("sameFunId" ,("Atools.sameFunId", + eval_same_funid "Atools.sameFunId"))*) +fun eval_sameFunId _ "Atools.sameFunId" + (p as Const ("Atools.sameFunId",_) $ + (f1 $ _) $ + (Const ("op =", _) $ (f2 $ _) $ _)) _ = + if f1 = f2 + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) +| eval_sameFunId _ _ _ _ = NONE; + + +(*.from a list of fun-definitions "f x = ..." as 2nd argument + filter the elements with the same fun-identfier in "f y" + as the fst argument; + this is, because Isabelles filter takes more than 1 sec.*) +fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2 + | same_funid f1 t = raise error ("same_funid called with t = (" + ^term2str f1^") ("^term2str t^")"); +(*("filter_sameFunId" ,("Atools.filter'_sameFunId", + eval_filter_sameFunId "Atools.filter'_sameFunId"))*) +fun eval_filter_sameFunId _ "Atools.filter'_sameFunId" + (p as Const ("Atools.filter'_sameFunId",_) $ + (fid $ _) $ fs) _ = + let val fs' = ((list2isalist HOLogic.boolT) o + (filter (same_funid fid))) (isalist2list fs) + in SOME (term2str (mk_equality (p, fs')), + Trueprop $ (mk_equality (p, fs'))) end +| eval_filter_sameFunId _ _ _ _ = NONE; + + +(*make a list of terms to a sum*) +fun list2sum [] = error ("list2sum called with []") + | list2sum [s] = s + | list2sum (s::ss) = + let fun sum su [s'] = + Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ su $ s' + | sum su (s'::ss') = + sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ su $ s') ss' + in sum s ss end; + +(*make a list of equalities to the sum of the lhs*) +(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*) +fun eval_boollist2sum _ "Atools.boollist2sum" + (p as Const ("Atools.boollist2sum", _) $ + (l as Const ("List.list.Cons", _) $ _ $ _)) _ = + let val isal = isalist2list l + val lhss = map lhs isal + val sum = list2sum lhss + in SOME ((term2str p) ^ " = " ^ (term2str sum), + Trueprop $ (mk_equality (p, sum))) + end +| eval_boollist2sum _ _ _ _ = NONE; + + + +local + +open Term; + +in +fun termlessI (_:subst) uv = termless uv; +fun term_ordI (_:subst) uv = term_ord uv; +end; + + +(** rule set, for evaluating list-expressions in scripts 8.01.02 **) + + +val list_rls = + append_rls "list_rls" list_rls + [Calc ("op *",eval_binop "#mult_"), + Calc ("op +", eval_binop "#add_"), + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*) + + Calc ("Tools.Vars",eval_var "#Vars_"), + + Thm ("if_True",num_str if_True), + Thm ("if_False",num_str if_False) + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("list_rls",list_rls) + ]); + +(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*) +val tless_true = dummy_ord; +rew_ord' := overwritel (!rew_ord', + [("tless_true", tless_true), + ("e_rew_ord'", tless_true), + ("dummy_ord", dummy_ord)]); + +val calculate_Atools = + append_rls "calculate_Atools" e_rls + [Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + Calc ("op =",eval_equal "#equal_"), + + Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_") + ]; + +val Atools_erls = + append_rls "Atools_erls" e_rls + [Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + (*"(~ True) = False"*) + Thm ("not_false",num_str not_false), + (*"(~ False) = True"*) + Thm ("and_true",and_true), + (*"(?a & True) = ?a"*) + Thm ("and_false",and_false), + (*"(?a & False) = False"*) + Thm ("or_true",or_true), + (*"(?a | True) = True"*) + Thm ("or_false",or_false), + (*"(?a | False) = ?a"*) + + Thm ("rat_leq1",rat_leq1), + Thm ("rat_leq2",rat_leq2), + Thm ("rat_leq3",rat_leq3), + Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ]; + +val Atools_crls = + append_rls "Atools_crls" e_rls + [Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + + Thm ("rat_leq1",rat_leq1), + Thm ("rat_leq2",rat_leq2), + Thm ("rat_leq3",rat_leq3), + Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ]; + +(*val atools_erls = ... waere zu testen ... + merge_rls calculate_Atools + (append_rls Atools_erls (*i.A. zu viele rules*) + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in", + eval_occurs_in "#occurs_in"), + Calc ("Tools.matches",eval_matches "#matches") + ] (*i.A. zu viele rules*) + );*) +(* val atools_erls = prep_rls( + Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + Thm ("and_commute",num_str and_commute), + Thm ("or_commute",num_str or_commute), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +ruleset' := overwritelth thy + (!ruleset', + [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*) + ]); +*) +"******* Atools.ML end *******"; + +calclist':= overwritel (!calclist', + [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")), + ("some_occur_in", + ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")), + ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")), + ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")), + ("is_const" ,("Atools.is'_const",eval_const "#is_const_")), + ("le" ,("op <" ,eval_equ "#less_")), + ("leq" ,("op <=" ,eval_equ "#less_equal_")), + ("ident" ,("Atools.ident",eval_ident "#ident_")), + ("equal" ,("op =",eval_equal "#equal_")), + ("PLUS" ,("op +" ,eval_binop "#add_")), + ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls + no script with "minus"*) + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_")), + ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum "")) + ]); + +val list_rls = prep_rls( + merge_rls "list_erls" + (Rls {id="replaced",preconds = [], + rew_ord = ("termlessI", termlessI), + erls = Rls {id="list_elrs", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = e_rls, + srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Calc ("op +", eval_binop "#add_"), + Calc ("op <",eval_equ "#less_") + (* ~~~~~~ for nth_Cons_*) + ], + scr = EmptyScr}, + srls = Erls, calc = [], (*asm_thm = [], *) + rules = [], scr = EmptyScr}) + list_rls); +ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Atools.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Atools.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,711 @@ +(* Title: tools for arithmetic + Author: Walther Neuper 010308 + (c) due to copyright terms + +remove_thy"Atools"; +use_thy"Knowledge/Atools"; +use_thy"Knowledge/Isac"; + +use_thy_only"Knowledge/Atools"; +use_thy"Knowledge/Isac"; +*) + +theory Atools imports Descript Typefix begin + +consts + + Arbfix :: "real" + Undef :: "real" + dummy :: "real" + + some'_occur'_in :: "[real list, 'a] => bool" ("some'_of _ occur'_in _") + occurs'_in :: "[real , 'a] => bool" ("_ occurs'_in _") + + pow :: "[real, real] => real" (infixr "^^^" 80) +(* ~~~ power doesn't allow Free("2",real) ^ Free("2",nat) + ~~~~ ~~~~ ~~~~ ~~~*) +(*WN0603 at Frontend encoded strings to '^', + see 'fun encode', fun 'decode'*) + + abs :: "real => real" ("(|| _ ||)") +(* ~~~ FIXXXME Isabelle2002 has abs already !!!*) + absset :: "real set => real" ("(||| _ |||)") + (*is numeral constant ?*) + is'_const :: "real => bool" ("_ is'_const" 10) + (*is_const rename to is_num FIXXXME.WN.16.5.03 *) + is'_atom :: "real => bool" ("_ is'_atom" 10) + is'_even :: "real => bool" ("_ is'_even" 10) + + (* identity on term level*) + ident :: "['a, 'a] => bool" ("(_ =!=/ _)" [51, 51] 50) + + argument'_in :: "real => real" ("argument'_in _" 10) + sameFunId :: "[real, bool] => bool" (**"same'_funid _ _" 10 + WN0609 changed the id, because ".. _ _" inhibits currying**) + filter'_sameFunId:: "[real, bool list] => bool list" + ("filter'_sameFunId _ _" 10) + boollist2sum :: "bool list => real" + +axioms (*for evaluating the assumptions of conditional rules*) + + last_thmI "lastI (x#xs) = (if xs =!= [] then x else lastI xs)" + real_unari_minus "- a = (-1) * a" (*Isa!*) + + rle_refl "(n::real) <= n" +(*reflI "(t = t) = True"*) + radd_left_cancel_le "((k::real) + m <= k + n) = (m <= n)" + not_true "(~ True) = False" + not_false "(~ False) = True" + and_true "(a & True) = a" + and_false "(a & False) = False" + or_true "(a | True) = True" + or_false "(a | False) = a" + and_commute "(a & b) = (b & a)" + or_commute "(a | b) = (b | a)" + + (*.should be in Rational.thy, but: + needed for asms in e.g. d2_pqformula1 in PolyEq.ML, RootEq.ML.*) + rat_leq1 "[| b ~= 0; d ~= 0 |] ==> \ + \((a / b) <= (c / d)) = ((a*d) <= (b*c))"(*Isa?*) + rat_leq2 "d ~= 0 ==> \ + \( a <= (c / d)) = ((a*d) <= c )"(*Isa?*) + rat_leq3 "b ~= 0 ==> \ + \((a / b) <= c ) = ( a <= (b*c))"(*Isa?*) + +text {*copy from doc/math-eng.tex WN.28.3.03 +WN071228 extended *} + + +section {*Coding standards*} +subsection {*Identifiers*} +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). + +This are the preliminary rules for naming identifiers> +\begin{description} +\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}. +\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}. +\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~! +\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}. +\item [???] ??? +\item [???] ??? +\end{description} +%WN071228 extended *} + +subsection {*Rule sets*} +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. + +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. +\begin{description} + +\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). + +\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. + +\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. +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). +\end{description} + +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. +The following rulesets are used for internal purposes and usually invisible to the (naive) user: +\begin{description} + +\item [*\_erls] +\item [*\_prls] +\item [*\_srls] + +\end{description} +{\tt append_rls, merge_rls, remove_rls} +*} + +ML {* + +(** evaluation of numerals and special predicates on the meta-level **) +(*-------------------------functions---------------------*) +local (* rlang 09.02 *) + (*.a 'c is coefficient of v' if v does occur in c.*) + fun coeff_in v c = member op = (vars c) v; +in + fun occurs_in v t = coeff_in v t; +end; + +(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*) +fun eval_occurs_in _ "Atools.occurs'_in" + (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ = + ((*writeln("@@@ eval_occurs_in: v= "^(term2str v)); + writeln("@@@ eval_occurs_in: t= "^(term2str t));*) + if occurs_in v t + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const)))) + | eval_occurs_in _ _ _ _ = NONE; + +(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*) +fun some_occur_in vs t = + let fun occurs_in' a b = occurs_in b a + in foldl or_ (false, map (occurs_in' t) vs) end; + +(*("some_occur_in", ("Atools.some'_occur'_in", + eval_some_occur_in "#eval_some_occur_in_"))*) +fun eval_some_occur_in _ "Atools.some'_occur'_in" + (p as (Const ("Atools.some'_occur'_in",_) + $ vs $ t)) _ = + if some_occur_in (isalist2list vs) t + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_some_occur_in _ _ _ _ = NONE; + + + + +(*evaluate 'is_atom'*) +(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*) +fun eval_is_atom (thmid:string) "Atools.is'_atom" + (t as (Const(op0,_) $ arg)) thy = + (case arg of + Free (n,_) => SOME (mk_thmid thmid op0 n "", + Trueprop $ (mk_equality (t, true_as_term))) + | _ => SOME (mk_thmid thmid op0 "" "", + Trueprop $ (mk_equality (t, false_as_term)))) + | eval_is_atom _ _ _ _ = NONE; + +(*evaluate 'is_even'*) +fun even i = (i div 2) * 2 = i; +(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*) +fun eval_is_even (thmid:string) "Atools.is'_even" + (t as (Const(op0,_) $ arg)) thy = + (case arg of + Free (n,_) => + (case int_of_str n of + SOME i => + if even i then SOME (mk_thmid thmid op0 n "", + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 "" "", + Trueprop $ (mk_equality (t, false_as_term))) + | _ => NONE) + | _ => NONE) + | eval_is_even _ _ _ _ = NONE; + +(*evaluate 'is_const'*) +(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*) +fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*) + (t as (Const(op0,t0) $ arg)) (thy:theory) = + (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*) + (case arg of + Const (n1,_) => + SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, false_as_term))) + | Free (n1,_) => + if is_numeral n1 + then SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 n1 "", + Trueprop $ (mk_equality (t, false_as_term))) + | Const ("Float.Float",_) => + SOME (mk_thmid thmid op0 (term2str arg) "", + Trueprop $ (mk_equality (t, true_as_term))) + | _ => (*NONE*) + SOME (mk_thmid thmid op0 (term2str arg) "", + Trueprop $ (mk_equality (t, false_as_term)))) + | eval_const _ _ _ _ = NONE; + +(*. evaluate binary, associative, commutative operators: *,+,^ .*) +(*("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*) + +(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) = + ("xxxxxx",op_,t,thy); + *) +fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) = + thmid ^ "Float ((" ^ + (string_of_int v11)^","^(string_of_int v12)^"), ("^ + (string_of_int p11)^","^(string_of_int p12)^")) __ (("^ + (string_of_int v21)^","^(string_of_int v22)^"), ("^ + (string_of_int p21)^","^(string_of_int p22)^"))"; + +(*.convert int and float to internal floatingpoint prepresentation.*) +fun numeral (Free (str, T)) = + (case int_of_str str of + SOME i => SOME ((i, 0), (0, 0)) + | NONE => NONE) + | numeral (Const ("Float.Float", _) $ + (Const ("Pair", _) $ + (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $ + (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))= + (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of + (SOME v1', SOME v2', SOME p1', SOME p2') => + SOME ((v1', v2'), (p1', p2')) + | _ => NONE) + | numeral _ = NONE; + +(*.evaluate binary associative operations.*) +fun eval_binop (thmid:string) (op_:string) + (t as ( Const(op0,t0) $ + (Const(op0',t0') $ v $ t1) $ t2)) + thy = (*binary . (v.n1).n2*) + if op0 = op0' then + case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + let val (T1,T2,Trange) = dest_binop_typ t0 + val res = calc (if op0 = "op -" then "op +" else op0) n1 n2 + (*WN071229 "HOL.divide" never tried*) + val rhs = var_op_float v op_ t0 T1 res + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE + else NONE + | eval_binop (thmid:string) (op_:string) + (t as + (Const (op0, t0) $ t1 $ + (Const (op0', t0') $ t2 $ v))) + thy = (*binary . n1.(n2.v)*) + if op0 = op0' then + case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + if op0 = "op -" then NONE else + let val (T1,T2,Trange) = dest_binop_typ t0 + val res = calc op0 n1 n2 + val rhs = float_op_var v op_ t0 T1 res + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE + else NONE + + | eval_binop (thmid:string) (op_:string) + (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*) + (case (numeral t1, numeral t2) of + (SOME n1, SOME n2) => + let val (T1,T2,Trange) = dest_binop_typ t0; + val res = calc op0 n1 n2; + val rhs = term_of_float Trange res; + val prop = Trueprop $ (mk_equality (t, rhs)); + in SOME (mk_thmid_f thmid n1 n2, prop) end + | _ => NONE) + | eval_binop _ _ _ _ = NONE; +(* +> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy; +> term2str t; +val it = "-1 + 2 = 1" +> val t = str2term "-1 * (-1 * a)"; +> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy; +> term2str t; +val it = "-1 * (-1 * a) = 1 * a"*) + + + +(*.evaluate < and <= for numerals.*) +(*("le" ,("op <" ,eval_equ "#less_")), + ("leq" ,("op <=" ,eval_equ "#less_equal_"))*) +fun eval_equ (thmid:string) (op_:string) (t as + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = + (case (int_of_str n1, int_of_str n2) of + (SOME n1', SOME n2') => + if calc_equ (strip_thy op0) (n1', n2') + then SOME (mk_thmid thmid op0 n1 n2, + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 n1 n2, + Trueprop $ (mk_equality (t, false_as_term))) + | _ => NONE) + + | eval_equ _ _ _ _ = NONE; + + +(*evaluate identity +> reflI; +val it = "(?t = ?t) = True" +> val t = str2term "x = 0"; +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; + +> val t = str2term "1 = 0"; +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t; +----------- thus needs Calc ! +> val t = str2term "0 = 0"; +> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t; +> term2str t'; +val it = "True" + +val t = str2term "Not (x = 0)"; +atomt t; term2str t; +*** ------------- +*** Const ( Not) +*** . Const ( op =) +*** . . Free ( x, ) +*** . . Free ( 0, ) +val it = "x ~= 0" : string*) + +(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of + the arguments: thus special handling by 'fun eval_binop'*) +(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*) +fun eval_ident (thmid:string) "Atools.ident" (t as + (Const (op0,t0) $ t1 $ t2 )) thy = + if t1 = t2 + then SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, false_as_term))) + | eval_ident _ _ _ _ = NONE; +(* TODO +> val t = str2term "x =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(x)_(0)" : string +val it = "(x =!= 0) = False" : string +> val t = str2term "1 =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(1)_(0)" : string +val it = "(1 =!= 0) = False" : string +> val t = str2term "0 =!= 0"; +> val SOME (str, t') = eval_ident "ident_" "b" t thy; +> term2str t'; +val str = "ident_(0)_(0)" : string +val it = "(0 =!= 0) = True" : string +*) + +(*.evaluate identity of terms, which stay ready for evaluation in turn; + thus returns False only for atoms.*) +(*("equal" ,("op =",eval_equal "#equal_")):calc*) +fun eval_equal (thmid:string) "op =" (t as + (Const (op0,t0) $ t1 $ t2 )) thy = + if t1 = t2 + then ((*writeln"... eval_equal: t1 = t2 --> True";*) + SOME (mk_thmid thmid op0 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")") + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"), + Trueprop $ (mk_equality (t, true_as_term))) + ) + else (case (is_atom t1, is_atom t2) of + (true, true) => + ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*) + SOME (mk_thmid thmid op0 + ("("^(term2str t1)^")") ("("^(term2str t2)^")"), + Trueprop $ (mk_equality (t, false_as_term))) + ) + | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*) + NONE)) + | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit"; + NONE); +(* +val t = str2term "x ~= 0"; +val NONE = eval_equal "equal_" "b" t thy; + + +> val t = str2term "(x + 1) = (x + 1)"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(x + 1)_(x + 1)" : string +val it = "(x + 1 = x + 1) = True" : string +> val t = str2term "x = 0"; +> val NONE = eval_equal "equal_" "b" t thy; + +> val t = str2term "1 = 0"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(1)_(0)" : string +val it = "(1 = 0) = False" : string +> val t = str2term "0 = 0"; +> val SOME (str, t') = eval_equal "equal_" "b" t thy; +> term2str t'; +val str = "equal_(0)_(0)" : string +val it = "(0 = 0) = True" : string +*) + + +(** evaluation on the metalevel **) + +(*. evaluate HOL.divide .*) +(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*) +fun eval_cancel (thmid:string) "HOL.divide" (t as + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy = + (case (int_of_str n1, int_of_str n2) of + (SOME n1', SOME n2') => + let + val sg = sign2 n1' n2'; + val (T1,T2,Trange) = dest_binop_typ t0; + val gcd' = gcd (abs n1') (abs n2'); + in if gcd' = abs n2' + then let val rhs = term_of_num Trange (sg * (abs n1') div gcd') + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid thmid op0 n1 n2, prop) end + else if 0 < n2' andalso gcd' = 1 then NONE + else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd') + ((abs n2') div gcd') + val prop = Trueprop $ (mk_equality (t, rhs)) + in SOME (mk_thmid thmid op0 n1 n2, prop) end + end + | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE)) + + | eval_cancel _ _ _ _ = NONE; + +(*. get the argument from a function-definition.*) +(*("argument_in" ,("Atools.argument'_in", + eval_argument_in "Atools.argument'_in"))*) +fun eval_argument_in _ "Atools.argument'_in" + (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ = + if is_Free arg (*could be something to be simplified before*) + then SOME (term2str t ^ " = " ^ term2str arg, + Trueprop $ (mk_equality (t, arg))) + else NONE + | eval_argument_in _ _ _ _ = NONE; + +(*.check if the function-identifier of the first argument matches + the function-identifier of the lhs of the second argument.*) +(*("sameFunId" ,("Atools.sameFunId", + eval_same_funid "Atools.sameFunId"))*) +fun eval_sameFunId _ "Atools.sameFunId" + (p as Const ("Atools.sameFunId",_) $ + (f1 $ _) $ + (Const ("op =", _) $ (f2 $ _) $ _)) _ = + if f1 = f2 + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) +| eval_sameFunId _ _ _ _ = NONE; + + +(*.from a list of fun-definitions "f x = ..." as 2nd argument + filter the elements with the same fun-identfier in "f y" + as the fst argument; + this is, because Isabelles filter takes more than 1 sec.*) +fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2 + | same_funid f1 t = raise error ("same_funid called with t = (" + ^term2str f1^") ("^term2str t^")"); +(*("filter_sameFunId" ,("Atools.filter'_sameFunId", + eval_filter_sameFunId "Atools.filter'_sameFunId"))*) +fun eval_filter_sameFunId _ "Atools.filter'_sameFunId" + (p as Const ("Atools.filter'_sameFunId",_) $ + (fid $ _) $ fs) _ = + let val fs' = ((list2isalist HOLogic.boolT) o + (filter (same_funid fid))) (isalist2list fs) + in SOME (term2str (mk_equality (p, fs')), + Trueprop $ (mk_equality (p, fs'))) end +| eval_filter_sameFunId _ _ _ _ = NONE; + + +(*make a list of terms to a sum*) +fun list2sum [] = error ("list2sum called with []") + | list2sum [s] = s + | list2sum (s::ss) = + let fun sum su [s'] = + Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ su $ s' + | sum su (s'::ss') = + sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ su $ s') ss' + in sum s ss end; + +(*make a list of equalities to the sum of the lhs*) +(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*) +fun eval_boollist2sum _ "Atools.boollist2sum" + (p as Const ("Atools.boollist2sum", _) $ + (l as Const ("List.list.Cons", _) $ _ $ _)) _ = + let val isal = isalist2list l + val lhss = map lhs isal + val sum = list2sum lhss + in SOME ((term2str p) ^ " = " ^ (term2str sum), + Trueprop $ (mk_equality (p, sum))) + end +| eval_boollist2sum _ _ _ _ = NONE; + + + +local + +open Term; + +in +fun termlessI (_:subst) uv = termless uv; +fun term_ordI (_:subst) uv = term_ord uv; +end; + + +(** rule set, for evaluating list-expressions in scripts 8.01.02 **) + + +val list_rls = + append_rls "list_rls" list_rls + [Calc ("op *",eval_binop "#mult_"), + Calc ("op +", eval_binop "#add_"), + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*) + + Calc ("Tools.Vars",eval_var "#Vars_"), + + Thm ("if_True",num_str if_True), + Thm ("if_False",num_str if_False) + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("list_rls",list_rls) + ]); + +(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*) +val tless_true = dummy_ord; +rew_ord' := overwritel (!rew_ord', + [("tless_true", tless_true), + ("e_rew_ord'", tless_true), + ("dummy_ord", dummy_ord)]); + +val calculate_Atools = + append_rls "calculate_Atools" e_rls + [Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + Calc ("op =",eval_equal "#equal_"), + + Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_") + ]; + +val Atools_erls = + append_rls "Atools_erls" e_rls + [Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + (*"(~ True) = False"*) + Thm ("not_false",num_str not_false), + (*"(~ False) = True"*) + Thm ("and_true",and_true), + (*"(?a & True) = ?a"*) + Thm ("and_false",and_false), + (*"(?a & False) = False"*) + Thm ("or_true",or_true), + (*"(?a | True) = True"*) + Thm ("or_false",or_false), + (*"(?a | False) = ?a"*) + + Thm ("rat_leq1",rat_leq1), + Thm ("rat_leq2",rat_leq2), + Thm ("rat_leq3",rat_leq3), + Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ]; + +val Atools_crls = + append_rls "Atools_crls" e_rls + [Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + + Thm ("rat_leq1",rat_leq1), + Thm ("rat_leq2",rat_leq2), + Thm ("rat_leq3",rat_leq3), + Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ]; + +(*val atools_erls = ... waere zu testen ... + merge_rls calculate_Atools + (append_rls Atools_erls (*i.A. zu viele rules*) + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in", + eval_occurs_in "#occurs_in"), + Calc ("Tools.matches",eval_matches "#matches") + ] (*i.A. zu viele rules*) + );*) +(* val atools_erls = prep_rls( + Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + Thm ("and_commute",num_str and_commute), + Thm ("or_commute",num_str or_commute), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +ruleset' := overwritelth thy + (!ruleset', + [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*) + ]); +*) +"******* Atools.ML end *******"; + +calclist':= overwritel (!calclist', + [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")), + ("some_occur_in", + ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")), + ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")), + ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")), + ("is_const" ,("Atools.is'_const",eval_const "#is_const_")), + ("le" ,("op <" ,eval_equ "#less_")), + ("leq" ,("op <=" ,eval_equ "#less_equal_")), + ("ident" ,("Atools.ident",eval_ident "#ident_")), + ("equal" ,("op =",eval_equal "#equal_")), + ("PLUS" ,("op +" ,eval_binop "#add_")), + ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls + no script with "minus"*) + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_")), + ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum "")) + ]); + +val list_rls = prep_rls( + merge_rls "list_erls" + (Rls {id="replaced",preconds = [], + rew_ord = ("termlessI", termlessI), + erls = Rls {id="list_elrs", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = e_rls, + srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Calc ("op +", eval_binop "#add_"), + Calc ("op <",eval_equ "#less_") + (* ~~~~~~ for nth_Cons_*) + ], + scr = EmptyScr}, + srls = Erls, calc = [], (*asm_thm = [], *) + rules = [], scr = EmptyScr}) + list_rls); +ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]); +*} + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Biegelinie.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Biegelinie.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,468 @@ +(* chapter 'Biegelinie' from the textbook: + Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271. + authors: Walther Neuper 2005 + (c) due to copyright terms + +use"Knowledge/Biegelinie.ML"; +use"Biegelinie.ML"; + +remove_thy"Typefix"; +remove_thy"Biegelinie"; +use_thy"Knowledge/Isac"; +*) + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("Biegelinie.thy",Biegelinie.thy)]); + +(** theory elements **) + +store_isa ["IsacKnowledge"] []; +store_thy Biegelinie.thy + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_isa ["IsacKnowledge", theory2thyID Biegelinie.thy, "Theorems"] + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Belastung_Querkraft", Belastung_Querkraft) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Moment_Neigung", Moment_Neigung) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Moment_Querkraft", Moment_Querkraft) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Neigung_Moment", Neigung_Moment) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Querkraft_Belastung", Querkraft_Belastung) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("Querkraft_Moment", Querkraft_Moment) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; +store_thm Biegelinie.thy ("make_fun_explicit", make_fun_explicit) + ["Walther Neuper 2005 supported by a grant from NMI Austria"]; + + +(** problems **) + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg" [] e_pblID + (["Biegelinien"], + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]), + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) + ("#Find" ,["Biegelinie b_"]), + ("#Relate",["Randbedingungen rb_"]) + ], + append_rls "e_rls" e_rls [], + NONE, + [["IntegrierenUndKonstanteBestimmen2"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_mom" [] e_pblID + (["MomentBestimmte","Biegelinien"], + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]), + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) + ("#Find" ,["Biegelinie b_"]), + ("#Relate",["RandbedingungenBiegung rb_","RandbedingungenMoment rm_"]) + ], + append_rls "e_rls" e_rls [], + NONE, + [["IntegrierenUndKonstanteBestimmen"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_momg" [] e_pblID + (["MomentGegebene","Biegelinien"], + [], + append_rls "e_rls" e_rls [], + NONE, + [["IntegrierenUndKonstanteBestimmen","2xIntegrieren"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_einf" [] e_pblID + (["einfache","Biegelinien"], + [], + append_rls "e_rls" e_rls [], + NONE, + [["IntegrierenUndKonstanteBestimmen","4x4System"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_momquer" [] e_pblID + (["QuerkraftUndMomentBestimmte","Biegelinien"], + [], + append_rls "e_rls" e_rls [], + NONE, + [["IntegrierenUndKonstanteBestimmen","1xIntegrieren"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_vonq" [] e_pblID + (["vonBelastungZu","Biegelinien"], + [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]), + ("#Find" ,["Funktionen funs___"])], + append_rls "e_rls" e_rls [], + NONE, + [["Biegelinien","ausBelastung"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_bieg_randbed" [] e_pblID + (["setzeRandbedingungen","Biegelinien"], + [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]), + ("#Find" ,["Gleichungen equs___"])], + append_rls "e_rls" e_rls [], + NONE, + [["Biegelinien","setzeRandbedingungenEin"]])); + +store_pbt + (prep_pbt Biegelinie.thy "pbl_equ_fromfun" [] e_pblID + (["makeFunctionTo","equation"], + [("#Given" ,["functionEq fun_","substitution sub_"]), + ("#Find" ,["equality equ___"])], + append_rls "e_rls" e_rls [], + NONE, + [["Equation","fromFunction"]])); + + + +(** methods **) + +val srls = Rls {id="srls_IntegrierenUnd..", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls + [(*for asm in nth_Cons_ ...*) + Calc ("op <",eval_equ "#less_"), + (*2nd nth_Cons_ pushes n+-1 into asms*) + Calc("op +", eval_binop "#add_") + ], + srls = Erls, calc = [], + rules = [Thm ("nth_Cons_",num_str nth_Cons_), + Calc("op +", eval_binop "#add_"), + Thm ("nth_Nil_",num_str nth_Nil_), + Calc("Tools.lhs", eval_lhs"eval_lhs_"), + Calc("Tools.rhs", eval_rhs"eval_rhs_"), + Calc("Atools.argument'_in", + eval_argument_in "Atools.argument'_in") + ], + scr = EmptyScr}; + +val srls2 = + Rls {id="srls_IntegrierenUnd..", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls + [(*for asm in nth_Cons_ ...*) + Calc ("op <",eval_equ "#less_"), + (*2nd nth_Cons_ pushes n+-1 into asms*) + Calc("op +", eval_binop "#add_") + ], + srls = Erls, calc = [], + rules = [Thm ("nth_Cons_",num_str nth_Cons_), + Calc("op +", eval_binop "#add_"), + Thm ("nth_Nil_", num_str nth_Nil_), + Calc("Tools.lhs", eval_lhs "eval_lhs_"), + Calc("Atools.filter'_sameFunId", + eval_filter_sameFunId "Atools.filter'_sameFunId"), + (*WN070514 just for smltest/../biegelinie.sml ...*) + Calc("Atools.sameFunId", eval_sameFunId "Atools.sameFunId"), + Thm ("filter_Cons", num_str filter_Cons), + Thm ("filter_Nil", num_str filter_Nil), + Thm ("if_True", num_str if_True), + Thm ("if_False", num_str if_False), + Thm ("hd_thm", num_str hd_thm) + ], + scr = EmptyScr}; +(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) +(* use"Knowledge/Biegelinie.ML"; + *) + +store_met + (prep_met Biegelinie.thy "met_biege" [] e_metID + (["IntegrierenUndKonstanteBestimmen"], + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__", + "FunktionsVariable v_"]), + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) + ("#Find" ,["Biegelinie b_"]), + ("#Relate",["RandbedingungenBiegung rb_", + "RandbedingungenMoment rm_"]) + ], + {rew_ord'="tless_true", + rls' = append_rls "erls_IntegrierenUndK.." e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false)], + calc = [], srls = srls, prls = Erls, + crls = Atools_erls, nrls = Erls}, +"Script BiegelinieScript \ +\(l_::real) (q__::real) (v_::real) (b_::real=>real) \ +\(rb_::bool list) (rm_::bool list) = \ +\ (let q___ = Take (q_ v_ = q__); \ +\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \ +\ (Rewrite Belastung_Querkraft True)) q___; \ +\ (Q__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs q___), real_ v_, real_real_ Q]); \ +\ Q__ = Rewrite Querkraft_Moment True Q__; \ +\ (M__::bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs Q__), real_ v_, real_real_ M_b]); \ +\ e1__ = nth_ 1 rm_; \ +\ (x1__::real) = argument_in (lhs e1__); \ +\ (M1__::bool) = (Substitute [v_ = x1__]) M__; \ +\ M1__ = (Substitute [e1__]) M1__ ; \ +\ M2__ = Take M__; "^ +(*without this Take 'Substitute [v_ = x2__]' takes _last formula from ctree_*) +" e2__ = nth_ 2 rm_; \ +\ (x2__::real) = argument_in (lhs e2__); \ +\ (M2__::bool) = ((Substitute [v_ = x2__]) @@ \ +\ (Substitute [e2__])) M2__; \ +\ (c_1_2__::bool list) = \ +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ +\ [booll_ [M1__, M2__], reall [c,c_2]]); \ +\ M__ = Take M__; \ +\ M__ = ((Substitute c_1_2__) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, c),(bdv_2, c_2)]\ +\ simplify_System False)) @@ \ +\ (Rewrite Moment_Neigung False) @@ \ +\ (Rewrite make_fun_explicit False)) M__; "^ +(*----------------------- and the same once more ------------------------*) +" (N__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs M__), real_ v_, real_real_ y']); \ +\ (B__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs N__), real_ v_, real_real_ y]); \ +\ e1__ = nth_ 1 rb_; \ +\ (x1__::real) = argument_in (lhs e1__); \ +\ (B1__::bool) = (Substitute [v_ = x1__]) B__; \ +\ B1__ = (Substitute [e1__]) B1__ ; \ +\ B2__ = Take B__; \ +\ e2__ = nth_ 2 rb_; \ +\ (x2__::real) = argument_in (lhs e2__); \ +\ (B2__::bool) = ((Substitute [v_ = x2__]) @@ \ +\ (Substitute [e2__])) B2__; \ +\ (c_1_2__::bool list) = \ +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ +\ [booll_ [B1__, B2__], reall [c,c_2]]); \ +\ B__ = Take B__; \ +\ B__ = ((Substitute c_1_2__) @@ \ +\ (Rewrite_Set_Inst [(bdv, x)] make_ratpoly_in False)) B__ \ +\ in B__)" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_2" [] e_metID + (["IntegrierenUndKonstanteBestimmen2"], + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__", + "FunktionsVariable v_"]), + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*) + ("#Find" ,["Biegelinie b_"]), + ("#Relate",["Randbedingungen rb_"]) + ], + {rew_ord'="tless_true", + rls' = append_rls "erls_IntegrierenUndK.." e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false)], + calc = [], + srls = append_rls "erls_IntegrierenUndK.." e_rls + [Calc("Tools.rhs", eval_rhs"eval_rhs_"), + Calc ("Atools.ident",eval_ident "#ident_"), + Thm ("last_thmI",num_str last_thmI), + Thm ("if_True",num_str if_True), + Thm ("if_False",num_str if_False) + ], + prls = Erls, crls = Atools_erls, nrls = Erls}, +"Script Biegelinie2Script \ +\(l_::real) (q__::real) (v_::real) (b_::real=>real) (rb_::bool list) = \ +\ (let \ +\ (funs_:: bool list) = \ +\ (SubProblem (Biegelinie_,[vonBelastungZu,Biegelinien], \ +\ [Biegelinien,ausBelastung]) \ +\ [real_ q__, real_ v_]); \ +\ (equs_::bool list) = \ +\ (SubProblem (Biegelinie_,[setzeRandbedingungen,Biegelinien],\ +\ [Biegelinien,setzeRandbedingungenEin]) \ +\ [booll_ funs_, booll_ rb_]); \ +\ (cons_::bool list) = \ +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \ +\ [booll_ equs_, reall [c,c_2,c_3,c_4]]); \ +\ B_ = Take (lastI funs_); \ +\ B_ = ((Substitute cons_) @@ \ +\ (Rewrite_Set_Inst [(bdv, v_)] make_ratpoly_in False)) B_ \ +\ in B_)" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_intconst_2" [] e_metID + (["IntegrierenUndKonstanteBestimmen","2xIntegrieren"], + [], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"empty_script" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_intconst_4" [] e_metID + (["IntegrierenUndKonstanteBestimmen","4x4System"], + [], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"empty_script" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_intconst_1" [] e_metID + (["IntegrierenUndKonstanteBestimmen","1xIntegrieren"], + [], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"empty_script" +)); + +store_met + (prep_met Biegelinie.thy "met_biege2" [] e_metID + (["Biegelinien"], + [], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"empty_script" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_ausbelast" [] e_metID + (["Biegelinien","ausBelastung"], + [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]), + ("#Find" ,["Funktionen funs_"])], + {rew_ord'="tless_true", + rls' = append_rls "erls_ausBelastung" e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false)], + calc = [], + srls = append_rls "srls_ausBelastung" e_rls + [Calc("Tools.rhs", eval_rhs"eval_rhs_")], + prls = e_rls, crls = Atools_erls, nrls = e_rls}, +"Script Belastung2BiegelScript (q__::real) (v_::real) = \ +\ (let q___ = Take (q_ v_ = q__); \ +\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \ +\ (Rewrite Belastung_Querkraft True)) q___; \ +\ (Q__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs q___), real_ v_, real_real_ Q]); \ +\ M__ = Rewrite Querkraft_Moment True Q__; \ +\ (M__::bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs M__), real_ v_, real_real_ M_b]); \ +\ N__ = ((Rewrite Moment_Neigung False) @@ \ +\ (Rewrite make_fun_explicit False)) M__; \ +\ (N__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs N__), real_ v_, real_real_ y']); \ +\ (B__:: bool) = \ +\ (SubProblem (Biegelinie_,[named,integrate,function], \ +\ [diff,integration,named]) \ +\ [real_ (rhs N__), real_ v_, real_real_ y]) \ +\ in [Q__, M__, N__, B__])" +)); + +store_met + (prep_met Biegelinie.thy "met_biege_setzrand" [] e_metID + (["Biegelinien","setzeRandbedingungenEin"], + [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]), + ("#Find" ,["Gleichungen equs___"])], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = srls2, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \ +\ (let b1_ = nth_ 1 rb_; \ +\ fs_ = filter_sameFunId (lhs b1_) funs_; \ +\ (e1_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b1_]); \ +\ b2_ = nth_ 2 rb_; \ +\ fs_ = filter_sameFunId (lhs b2_) funs_; \ +\ (e2_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b2_]); \ +\ b3_ = nth_ 3 rb_; \ +\ fs_ = filter_sameFunId (lhs b3_) funs_; \ +\ (e3_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b3_]); \ +\ b4_ = nth_ 4 rb_; \ +\ fs_ = filter_sameFunId (lhs b4_) funs_; \ +\ (e4_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b4_]) \ +\ in [e1_,e2_,e3_,e4_])" +(* filter requires more than 1 sec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \ +\ (let b1_ = nth_ 1 rb_; \ +\ fs_ = filter (sameFunId (lhs b1_)) funs_; \ +\ (e1_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b1_]); \ +\ b2_ = nth_ 2 rb_; \ +\ fs_ = filter (sameFunId (lhs b2_)) funs_; \ +\ (e2_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b2_]); \ +\ b3_ = nth_ 3 rb_; \ +\ fs_ = filter (sameFunId (lhs b3_)) funs_; \ +\ (e3_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b3_]); \ +\ b4_ = nth_ 4 rb_; \ +\ fs_ = filter (sameFunId (lhs b4_)) funs_; \ +\ (e4_::bool) = \ +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\ +\ [Equation,fromFunction]) \ +\ [bool_ (hd fs_), bool_ b4_]) \ +\ in [e1_,e2_,e3_,e4_])"*) +)); + +store_met + (prep_met Biegelinie.thy "met_equ_fromfun" [] e_metID + (["Equation","fromFunction"], + [("#Given" ,["functionEq fun_","substitution sub_"]), + ("#Find" ,["equality equ___"])], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = append_rls "srls_in_EquationfromFunc" e_rls + [Calc("Tools.lhs", eval_lhs"eval_lhs_"), + Calc("Atools.argument'_in", + eval_argument_in + "Atools.argument'_in")], + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +(*(M_b x = c_2 + c * x + -1 * q_0 / 2 * x ^^^ 2) (M_b L = 0) --> + 0 = c_2 + c * L + -1 * q_0 / 2 * L ^^^ 2*) +"Script Function2Equality (fun_::bool) (sub_::bool) =\ +\ (let fun_ = Take fun_; \ +\ bdv_ = argument_in (lhs fun_); \ +\ val_ = argument_in (lhs sub_); \ +\ equ_ = (Substitute [bdv_ = val_]) fun_; \ +\ equ_ = (Substitute [sub_]) fun_ \ +\ in (Rewrite_Set norm_Rational False) equ_) " +)); + + + +(* use"Knowledge/Biegelinie.ML"; + *) \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Biegelinie.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Biegelinie.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,82 @@ +(* chapter 'Biegelinie' from the textbook: + Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271. + author: Walther Neuper + 050826, + (c) due to copyright terms + +remove_thy"Biegelinie"; +use_thy"Knowledge/Biegelinie"; +use_thy_only"Knowledge/Biegelinie"; + +remove_thy"Biegelinie"; +use_thy"Knowledge/Isac"; +*) + +Biegelinie = Integrate + Equation + EqSystem + + +consts + + q_ :: real => real ("q'_") (* Streckenlast *) + Q :: real => real (* Querkraft *) + Q' :: real => real (* Ableitung der Querkraft *) + M'_b :: real => real ("M'_b") (* Biegemoment *) + M'_b' :: real => real ("M'_b'") (* Ableitung des Biegemoments *) + y'' :: real => real (* 2.Ableitung der Biegeline *) + y' :: real => real (* Neigung der Biegeline *) +(*y :: real => real (* Biegeline *)*) + EI :: real (* Biegesteifigkeit *) + + (*new Descriptions in the related problems*) + Traegerlaenge :: real => una + Streckenlast :: real => una + BiegemomentVerlauf :: bool => una + Biegelinie :: (real => real) => una + Randbedingungen :: bool list => una + RandbedingungenBiegung :: bool list => una + RandbedingungenNeigung :: bool list => una + RandbedingungenMoment :: bool list => una + RandbedingungenQuerkraft :: bool list => una + FunktionsVariable :: real => una + Funktionen :: bool list => una + Gleichungen :: bool list => una + + (*Script-names*) + Biegelinie2Script :: "[real,real,real,real=>real,bool list, + bool] => bool" + ("((Script Biegelinie2Script (_ _ _ _ _ =))// (_))" 9) + BiegelinieScript :: "[real,real,real,real=>real,bool list,bool list, + bool] => bool" + ("((Script BiegelinieScript (_ _ _ _ _ _ =))// (_))" 9) + Biege2xIntegrierenScript :: "[real,real,real,bool,real=>real,bool list, + bool] => bool" + ("((Script Biege2xIntegrierenScript (_ _ _ _ _ _ =))// (_))" 9) + Biege4x4SystemScript :: "[real,real,real,real=>real,bool list, + bool] => bool" + ("((Script Biege4x4SystemScript (_ _ _ _ _ =))// (_))" 9) + Biege1xIntegrierenScript :: + "[real,real,real,real=>real,bool list,bool list,bool list, + bool] => bool" + ("((Script Biege1xIntegrierenScript (_ _ _ _ _ _ _ =))// (_))" 9) + Belastung2BiegelScript :: "[real,real, + bool list] => bool list" + ("((Script Belastung2BiegelScript (_ _ =))// (_))" 9) + SetzeRandbedScript :: "[bool list,bool list, + bool list] => bool list" + ("((Script SetzeRandbedScript (_ _ =))// (_))" 9) + +rules + + Querkraft_Belastung "Q' x = -q_ x" + Belastung_Querkraft "-q_ x = Q' x" + + Moment_Querkraft "M_b' x = Q x" + Querkraft_Moment "Q x = M_b' x" + + Neigung_Moment "y'' x = -M_b x/ EI" + Moment_Neigung "M_b x = -EI * y'' x" + + (*according to rls 'simplify_Integral': .. = 1/a * .. instead .. = ../ a*) + make_fun_explicit "Not (a =!= 0) ==> (a * (f x) = b) = (f x = 1/a * b)" + +end + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Calculus.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Calculus.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,4 @@ + +Calculus = Real + + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Descript.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Descript.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,52 @@ +(* Title: descriptions for items in model-patterns of problems and in method's + guards + Author: Walther Neuper 000301 + (c) due to copyright terms + + see WN, Reactive User-Guidance ... Vers. Oct.2000 p.48 ff + +remove_thy"Descript"; +use_thy"Knowledge/Descript"; +use_thy_only"Knowledge/Descript"; + +remove_thy"Typefix"; +use_thy"Knowledge/Isac"; +*) + +theory Descript imports "../ProgLang/Script" begin + +consts + + someList :: "'a list => unl" (*not for elementwise input, eg. inssort*) + + additionalRels :: "bool list => una" + boundVariable :: "real => una" +(*derivative :: 'a => toreal 28.11.00*) + derivative :: "real => una" + equalities :: "bool list => tobooll" (*WN071228 see fixedValues*) + equality :: "bool => una" + errorBound :: "bool => nam" + + fixedValues :: "bool list => nam" + functionEq :: "bool => una" (*6.5.03: functionTerm -> functionEq*) + antiDerivative :: "bool => una" + functionOf :: "real => una" +(*functionTerm :: 'a => toreal 28.11.00*) + functionTerm :: "real => una" (*6.5.03: functionTerm -> functionEq*) + interval :: "real set => una" + maxArgument :: "bool => toreal" + maximum :: "real => toreal" + + relations :: "bool list => una" + solutions :: "bool list => toreall" +(*solution :: bool => toreal WN0509 bool list=> toreall --->EqSystem*) + solveFor :: "real => una" + differentiateFor:: "real => una" + unknown :: "'a => unknow" + valuesFor :: "real list => toreall" + + realTestGiven :: "real => una" + realTestFind :: "real => una" + boolTestGiven :: "bool => una" + boolTestFind :: "bool => una" + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Diff.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Diff.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,370 @@ +(* tools for differentiation + WN.11.99 + +use"Knowledge/Diff.ML"; +use"Diff.ML"; + *) + + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("Diff.thy",Diff.thy)]); + + +(** eval functions **) + +fun primed (Const (id, T)) = Const (id ^ "'", T) + | primed (Free (id, T)) = Free (id ^ "'", T) + | primed t = raise error ("primed called with arg = '"^ term2str t ^"'"); + +(*("primed", ("Diff.primed", eval_primed "#primed"))*) +fun eval_primed _ _ (p as (Const ("Diff.primed",_) $ t)) _ = + SOME ((term2str p) ^ " = " ^ term2str (primed t), + Trueprop $ (mk_equality (p, primed t))) + | eval_primed _ _ _ _ = NONE; + +calclist':= overwritel (!calclist', + [("primed", ("Diff.primed", eval_primed "#primed")) + ]); + + +(** rulesets **) + +(*.converts a term such that differentiation works optimally.*) +val diff_conv = + Rls {id="diff_conv", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = append_rls "erls_diff_conv" e_rls + [Calc ("Atools.occurs'_in", eval_occurs_in ""), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Calc ("op <",eval_equ "#less_"), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false) + ], + srls = Erls, calc = [], + rules = [Thm ("frac_conv", num_str frac_conv), + Thm ("sqrt_conv_bdv", num_str sqrt_conv_bdv), + Thm ("sqrt_conv_bdv_n", num_str sqrt_conv_bdv_n), + Thm ("sqrt_conv", num_str sqrt_conv), + Thm ("root_conv", num_str root_conv), + Thm ("realpow_pow_bdv", num_str realpow_pow_bdv), + Calc ("op *", eval_binop "#mult_"), + Thm ("rat_mult",num_str rat_mult), + (*a / b * (c / d) = a * c / (b * d)*) + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), + (*?x * (?y / ?z) = ?x * ?y / ?z*) + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq) + (*?y / ?z * ?x = ?y * ?x / ?z*) + (* + Thm ("", num_str ),*) + ], + scr = EmptyScr}; + +(*.beautifies a term after differentiation.*) +val diff_sym_conv = + Rls {id="diff_sym_conv", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = append_rls "erls_diff_sym_conv" e_rls + [Calc ("op <",eval_equ "#less_") + ], + srls = Erls, calc = [], + rules = [Thm ("frac_sym_conv", num_str frac_sym_conv), + Thm ("sqrt_sym_conv", num_str sqrt_sym_conv), + Thm ("root_sym_conv", num_str root_sym_conv), + Thm ("sym_real_mult_minus1", + num_str (real_mult_minus1 RS sym)), + (*- ?z = "-1 * ?z"*) + Thm ("rat_mult",num_str rat_mult), + (*a / b * (c / d) = a * c / (b * d)*) + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), + (*?x * (?y / ?z) = ?x * ?y / ?z*) + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), + (*?y / ?z * ?x = ?y * ?x / ?z*) + Calc ("op *", eval_binop "#mult_") + ], + scr = EmptyScr}; + +(*..*) +val srls_diff = + Rls {id="srls_differentiate..", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = e_rls, + srls = Erls, calc = [], + rules = [Calc("Tools.lhs", eval_lhs "eval_lhs_"), + Calc("Tools.rhs", eval_rhs "eval_rhs_"), + Calc("Diff.primed", eval_primed "Diff.primed") + ], + scr = EmptyScr}; + +(*..*) +val erls_diff = + append_rls "erls_differentiate.." e_rls + [Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Atools.is'_const",eval_const "#is_const_") + ]; + +(*.rules for differentiation, _no_ simplification.*) +val diff_rules = + Rls {id="diff_rules", preconds = [], rew_ord = ("termlessI",termlessI), + erls = erls_diff, srls = Erls, calc = [], + rules = [Thm ("diff_sum",num_str diff_sum), + Thm ("diff_dif",num_str diff_dif), + Thm ("diff_prod_const",num_str diff_prod_const), + Thm ("diff_prod",num_str diff_prod), + Thm ("diff_quot",num_str diff_quot), + Thm ("diff_sin",num_str diff_sin), + Thm ("diff_sin_chain",num_str diff_sin_chain), + Thm ("diff_cos",num_str diff_cos), + Thm ("diff_cos_chain",num_str diff_cos_chain), + Thm ("diff_pow",num_str diff_pow), + Thm ("diff_pow_chain",num_str diff_pow_chain), + Thm ("diff_ln",num_str diff_ln), + Thm ("diff_ln_chain",num_str diff_ln_chain), + Thm ("diff_exp",num_str diff_exp), + Thm ("diff_exp_chain",num_str diff_exp_chain), +(* + Thm ("diff_sqrt",num_str diff_sqrt), + Thm ("diff_sqrt_chain",num_str diff_sqrt_chain), +*) + Thm ("diff_const",num_str diff_const), + Thm ("diff_var",num_str diff_var) + ], + scr = EmptyScr}; + +(*.normalisation for checking user-input.*) +val norm_diff = + Rls {id="diff_rls", preconds = [], rew_ord = ("termlessI",termlessI), + erls = Erls, srls = Erls, calc = [], + rules = [Rls_ diff_rules, + Rls_ norm_Poly + ], + scr = EmptyScr}; +ruleset' := +overwritelthy thy (!ruleset', + [("diff_rules", prep_rls norm_diff), + ("norm_diff", prep_rls norm_diff), + ("diff_conv", prep_rls diff_conv), + ("diff_sym_conv", prep_rls diff_sym_conv) + ]); + + +(** problem types **) + +store_pbt + (prep_pbt Diff.thy "pbl_fun" [] e_pblID + (["function"], [], e_rls, NONE, [])); + +store_pbt + (prep_pbt Diff.thy "pbl_fun_deriv" [] e_pblID + (["derivative_of","function"], + [("#Given" ,["functionTerm f_","differentiateFor v_"]), + ("#Find" ,["derivative f_'_"]) + ], + append_rls "e_rls" e_rls [], + SOME "Diff (f_, v_)", [["diff","differentiate_on_R"], + ["diff","after_simplification"]])); + +(*here "named" is used differently from Integration"*) +store_pbt + (prep_pbt Diff.thy "pbl_fun_deriv_nam" [] e_pblID + (["named","derivative_of","function"], + [("#Given" ,["functionEq f_","differentiateFor v_"]), + ("#Find" ,["derivativeEq f_'_"]) + ], + append_rls "e_rls" e_rls [], + SOME "Differentiate (f_, v_)", [["diff","differentiate_equality"]])); + + +(** methods **) + +store_met + (prep_met Diff.thy "met_diff" [] e_metID + (["diff"], [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls = Atools_erls, nrls = norm_diff}, "empty_script")); + +store_met + (prep_met Diff.thy "met_diff_onR" [] e_metID + (["diff","differentiate_on_R"], + [("#Given" ,["functionTerm f_","differentiateFor v_"]), + ("#Find" ,["derivative f_'_"]) + ], + {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls, + prls=e_rls, crls = Atools_erls, nrls = norm_diff}, +"Script DiffScr (f_::real) (v_::real) = \ +\ (let f'_ = Take (d_d v_ f_) \ +\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ +\ (Repeat \ +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ +\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)" +)); + +store_met + (prep_met Diff.thy "met_diff_simpl" [] e_metID + (["diff","diff_simpl"], + [("#Given" ,["functionTerm f_","differentiateFor v_"]), + ("#Find" ,["derivative f_'_"]) + ], + {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls, + prls=e_rls, crls = Atools_erls, nrls = norm_diff}, +"Script DiffScr (f_::real) (v_::real) = \ +\ (let f'_ = Take (d_d v_ f_) \ +\ in (( \ +\ (Repeat \ +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ +\ (Repeat (Rewrite_Set make_polynomial False)))) \ +\ )) f'_)" + )); + +(*----------------------------------------------------------------- + "Script DiffScr (f_::real) (v_::real) = \ + \(Repeat \ + \ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ + \ (Repeat (Rewrite_Set make_polynomial False)))) \ + \ (f_::real)" +*) + +store_met + (prep_met Diff.thy "met_diff_equ" [] e_metID + (["diff","differentiate_equality"], + [("#Given" ,["functionEq f_","differentiateFor v_"]), + ("#Find" ,["derivativeEq f_'_"]) + ], + {rew_ord'="tless_true", rls' = erls_diff, calc = [], + srls = srls_diff, prls=e_rls, crls=Atools_erls, nrls = norm_diff}, +"Script DiffEqScr (f_::bool) (v_::real) = \ +\ (let f'_ = Take ((primed (lhs f_)) = d_d v_ (rhs f_)) \ +\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ +\ (Repeat \ +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_dif False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \ +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \ +\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)" +)); + + +store_met + (prep_met Diff.thy "met_diff_after_simp" [] e_metID + (["diff","after_simplification"], + [("#Given" ,["functionTerm f_","differentiateFor v_"]), + ("#Find" ,["derivative f_'_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, prls=e_rls, + crls=Atools_erls, nrls = norm_Rational}, +"Script DiffScr (f_::real) (v_::real) = \ +\ (let f'_ = Take (d_d v_ f_) \ +\ in ((Try (Rewrite_Set norm_Rational False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv,v_)] norm_diff False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)) @@ \ +\ (Try (Rewrite_Set norm_Rational False))) f'_)" +)); + + +(** CAS-commands **) + +(*.handle cas-input like "Diff (a * x^3 + b, x)".*) +(* val (t, pairl) = strip_comb (str2term "Diff (a * x^3 + b, x)"); + val [Const ("Pair", _) $ t $ bdv] = pairl; + *) +fun argl2dtss [Const ("Pair", _) $ t $ bdv] = + [((term_of o the o (parse thy)) "functionTerm", [t]), + ((term_of o the o (parse thy)) "differentiateFor", [bdv]), + ((term_of o the o (parse thy)) "derivative", + [(term_of o the o (parse thy)) "f_'_"]) + ] + | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss"; +castab := +overwritel (!castab, + [((term_of o the o (parse thy)) "Diff", + (("Isac.thy", ["derivative_of","function"], ["no_met"]), + argl2dtss)) + ]); + +(*.handle cas-input like "Differentiate (A = s * (a - s), s)".*) +(* val (t, pairl) = strip_comb (str2term "Differentiate (A = s * (a - s), s)"); + val [Const ("Pair", _) $ t $ bdv] = pairl; + *) +fun argl2dtss [Const ("Pair", _) $ t $ bdv] = + [((term_of o the o (parse thy)) "functionEq", [t]), + ((term_of o the o (parse thy)) "differentiateFor", [bdv]), + ((term_of o the o (parse thy)) "derivativeEq", + [(term_of o the o (parse thy)) "f_'_::bool"]) + ] + | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss"; +castab := +overwritel (!castab, + [((term_of o the o (parse thy)) "Differentiate", + (("Isac.thy", ["named","derivative_of","function"], ["no_met"]), + argl2dtss)) + ]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Diff.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Diff.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,97 @@ +(* differentiation over the reals + author: Walther Neuper + 000516 + +remove_thy"Diff"; +use_thy_only"Knowledge/Diff"; +use_thy"Knowledge/Isac"; + *) + +Diff = Calculus + Trig + LogExp + Rational + Root + Poly + Atools + + +consts + + d_d :: "[real, real]=> real" + sin, cos :: "real => real" +(* + log, ln :: "real => real" + nlog :: "[real, real] => real" + exp :: "real => real" ("E'_ ^^^ _" 80) +*) + (*descriptions in the related problems*) + derivativeEq :: bool => una + + (*predicates*) + primed :: "'a => 'a" (*"primed A" -> "A'"*) + + (*the CAS-commands, eg. "Diff (2*x^^^3, x)", + "Differentiate (A = s * (a - s), s)"*) + Diff :: "[real * real] => real" + Differentiate :: "[bool * real] => bool" + + (*subproblem and script-name*) + differentiate :: "[ID * (ID list) * ID, real,real] => real" + ("(differentiate (_)/ (_ _ ))" 9) + DiffScr :: "[real,real, real] => real" + ("((Script DiffScr (_ _ =))// (_))" 9) + DiffEqScr :: "[bool,real, bool] => bool" + ("((Script DiffEqScr (_ _ =))// (_))" 9) + + +rules (*stated as axioms, todo: prove as theorems + 'bdv' is a constant on the meta-level *) + diff_const "[| Not (bdv occurs_in a) |] ==> d_d bdv a = 0" + diff_var "d_d bdv bdv = 1" + diff_prod_const"[| Not (bdv occurs_in u) |] ==> \ + \d_d bdv (u * v) = u * d_d bdv v" + + diff_sum "d_d bdv (u + v) = d_d bdv u + d_d bdv v" + diff_dif "d_d bdv (u - v) = d_d bdv u - d_d bdv v" + diff_prod "d_d bdv (u * v) = d_d bdv u * v + u * d_d bdv v" + diff_quot "Not (v = 0) ==> (d_d bdv (u / v) = \ + \(d_d bdv u * v - u * d_d bdv v) / v ^^^ 2)" + + diff_sin "d_d bdv (sin bdv) = cos bdv" + diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u" + diff_cos "d_d bdv (cos bdv) = - sin bdv" + diff_cos_chain "d_d bdv (cos u) = - sin u * d_d bdv u" + diff_pow "d_d bdv (bdv ^^^ n) = n * (bdv ^^^ (n - 1))" + diff_pow_chain "d_d bdv (u ^^^ n) = n * (u ^^^ (n - 1)) * d_d bdv u" + diff_ln "d_d bdv (ln bdv) = 1 / bdv" + diff_ln_chain "d_d bdv (ln u) = d_d bdv u / u" + diff_exp "d_d bdv (exp bdv) = exp bdv" + diff_exp_chain "d_d bdv (exp u) = exp u * d_d x u" +(* + diff_sqrt "d_d bdv (sqrt bdv) = 1 / (2 * sqrt bdv)" + diff_sqrt_chain"d_d bdv (sqrt u) = d_d bdv u / (2 * sqrt u)" +*) + (*...*) + + frac_conv "[| bdv occurs_in b; 0 < n |] ==> \ + \ a / (b ^^^ n) = a * b ^^^ (-n)" + frac_sym_conv "n < 0 ==> a * b ^^^ n = a / b ^^^ (-n)" + + sqrt_conv_bdv "sqrt bdv = bdv ^^^ (1 / 2)" + sqrt_conv_bdv_n "sqrt (bdv ^^^ n) = bdv ^^^ (n / 2)" + sqrt_conv "bdv occurs_in u ==> sqrt u = u ^^^ (1 / 2)" + sqrt_sym_conv "u ^^^ (a / 2) = sqrt (u ^^^ a)" + + root_conv "bdv occurs_in u ==> nroot n u = u ^^^ (1 / n)" + root_sym_conv "u ^^^ (a / b) = nroot b (u ^^^ a)" + + realpow_pow_bdv "(bdv ^^^ b) ^^^ c = bdv ^^^ (b * c)" + +end + +(* a variant of the derivatives defintion: + + d_d :: "(real => real) => (real => real)" + + advantages: +(1) no variable 'bdv' on the meta-level required +(2) chain_rule "d_d (%x. (u (v x))) = (%x. (d_d u)) (v x) * d_d v" +(3) and no specialized chain-rules required like + diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u" + + disadvantage: d_d (%x. 1 + x^2) = ... differs from high-school notation +*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp-oldpbl.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp-oldpbl.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,369 @@ +(*8.01: aufgehoben wegen alter preconds, postconds*) + +(* rectangle with maximal area, inscribed in a circle of fixed radius + +problem-types and methods solving the respective problem-type + +(1) names of the problem-types and methods and their hierarchy + as subproblems. + names of problem-types are string lists (diss 5.3.), not shown + here with exception of ["equation","univariate"] in order to + indicate, that this particular problem needs refinement to a + more specific type of equation solvable by tan-square, etc. + +problem-types methods +------------------------------- ---------------------- +maximum maximum-by-differentiation + maximum-by-experimentation + make-fun make-explicit-and-substitute + introduce-a-new-variable + max-of-fun-on-interval max-of-fun-on-interval + derivative differentiate + ["equation","univariate"] tan-square + + find-values find-values + +(2) specification of the problem-types +*) + +(* maximum *) +(* ------- *) +(* problem-type *) +{given = ["fixed_values (cs::bool list)"], + where_= ["foldl (op &) True (map is_equality cs)", + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"], + find=["maximum m","values_for (ms::real list)"], + with_=["Ex_frees ((foldl (op &) True (r#RS)) & \ + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#RS)) \ + \ --> m' <= m)))"], + relate=["max_relation r","additional_relations RS"]}; +(* ^^^ is exponenation *) + +(* the functions Ex_frees, Rhs provide for the instantiation below *) + +(* (1) instantiation of maximum, + variant in "values_for" *) +{given = ["fixed_values (R = #7)"], + where_= ["is_equality (R = #7)", + "Not (R <= #0)"], + find =["maximum A","values_for [a,b]"], + with_ =["EX A. A = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \ + \ (ALL A'. A' = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \ + \ --> A' <= A)))"], + relate=["max_relation (A = a*b)", + "additional_relations [(a//#2)^^^#2 +(b//#2)^^^#2 =R^^^#2]"]}; +(* R,a,b are bound by given, find *) + +(* (2) instantiation of maximum *) +{given = ["fixed_values (R = #7)"], + where_= ["is_equality (R = #7)", + "Not (R <= #0)"], + find =["maximum A","values_for [A]"], + with_ =["EX a b alpha. A = a*b & \ + \ a = #2*R*sin alpha & b =#2*R*cos alpha &\ + \ (ALL A'. A' = a*b & a = #2*R*sin alpha & b =#2*R*cos alpha \ + \ --> A' <= A)))"], + relate=["max_relation (A = a*b)", + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]}; +(* R,A are bound by given, find *) + + +(* make-fun *) +(* -------- *) +(* problem-type *) +{given = ["equality (lhs = rhs)","bound_variable v","equalities es"], + where_= [], + find = ["function_term lhs_"], + with_ = [(*???*)], + relate= [(*???*)]}; +(*the _ in lhs is used to transfer the lhs-identifier of equality*) + +(* (1) instantiation for make-explicit-and-substitute *) +{given = ["equality A = a * b","bound_variable a", + "equalities [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"], + where_= [], + find = ["function_term A_"(*=(a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))*)], + with_ = [], + relate= []}; + +(* (2) instantiation for introduce-a-new-variable *) +{given = ["equality A = a * b","bound_variable alpha", + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], + where_= [], + find = ["function_term A_"(*=(#2*R*sin alpha *#2*R*cos alpha)*)], + with_ = [], + relate= []}; + + +(* max-of-fun-on-interval *) +(* ---------------------- *) +(* problem-type *) +{given = ["function_term t","bound_variable v", + "domain {x::real. lower_bound <= x & x <= upper_bound}"], + where_= [], + find = ["maximums ms"], + with_ = ["ALL m. m : ms --> \ + \ (ALL x::real. lower_bound <= x & x <= upper_bound \ + \ --> (%v. t) x <= m)"], + relate= []}: string ppc; +(* ':' is 'element', '::' is a type constraint *) + +(* (1) variant of instantiation *) +{given = ["function_term (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))", + "bound_variable a", + "domain {x::real. #0 <= x & x <= #2*R}"], + where_= [], + find = ["maximums AM"], + with_ = ["ALL am. am : AM --> \ + \ (ALL x::real. #0 <= x & x <= #2*R \ + \ --> (%a. (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))) x <= am)"], + relate= []}; + +(* (2) variant of instantiation *) +{given = ["function_term (#2*R*sin alpha * #2*R*cos alpha)", + "bound_variable alpha", + "domain {x::real. #0 <= x & x <= pi//#2}"], + where_= [], + find = ["maximums AM"], + with_ = ["ALL am. am : AM --> \ + \ (ALL x::real. #0 <= x & x <= pi//#2 \ + \ --> (%alpha. (#2*R*sin alpha * #2*R*cos alpha)) x <= am)"], + relate= []}; + + +(* derivative *) +(* ---------- *) +(* problem-type *) +{given = ["function_term t","bound_variable bdv"], + where_= [], + find = ["derivative t'"], + with_ = ["t' is_derivative_of (%bdv. t)"], + relate= []}; +(*the ' in t' is used to transfer the identifier from function_term*) + + +(* ["equation","univariate"] *) +(* ------------------------- *) +(* problem-type *) +{given = ["equality (lhs = rhs)", + "bound_variable v","error_bound eps"], + where_= [], + find = ["solutions S"], + with_ = ["ALL s. s : S --> || (%v. lhs) s - (%v. rhs) s || <= eps"], + relate= []}; + + +(* find-values *) +(* ----------- *) +(* problem-type *) +{given = ["max_relation r","additional_relations RS"], + where_= [], + find = ["values_for VS"], + with_ = [(*???*)], + relate= []}; + +(* (1) variant of instantiation *) +{given = ["max_relation (A = a*b)", + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]"], + where_= [], + find = ["values_for [a,b]"], + with_ = [], + relate= []}; + +(* (2) variant of instantiation *) +{given = ["max_relation (A = a*b)",], + where_= [], + find = ["values_for [A]", + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"], + with_ = [], + relate= []}; + +(* +(3) data-transfer between the the hidden formalization, + the root-problem and the sub-problems; + +maximum -> #given.make-fun +------------------- +maximum.#relate "max_relation r" -> "equality (lhs = rhs)" +formalization "bound_variable v" -> "bound_variable v" +maximum.#relate "additional_relations RS"-> "equalities es" + + +maximum + make-fun -> #given.max-of-fun-on-interval +-------------------------------------------- +make-fun.#find "function_term lhs_" -> "function_term t" +make-fun.#given "bound_variable v" -> "bound_variable v" +formalization -> "domain {x::real. ...}" + + +max-of-fun-on-interval -> #given.derivative +------------------------------------ +make-fun.#find "function_term lhs_" -> "function_term t" +make-fun.#given "bound_variable v" -> "bound_variable bdv" + + +max-of-fun-on-interval + derivative -> + #given.["equation","univariate"] +---------------------------------------------------------------- +derivative.#find "derivative t'" -> "equality (lhs = rhs)" + (* t'= #0 *) +make-fun.#given "bound_variable v" -> "bound_variable v" +formalization -> "error_bound eps" + + +maximum + make-fun + max-of-fun-on-interval -> #given.find-values +---------------------------------------------------------- +maximum.#relate "max_relation r" -> "max_relation r" +maximum.#relate "additional_relations RS"-> "additional_relations RS" +*) + + + + +(* vvv--- geht nicht wegen fun-types +parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')"; +parse thy "if maxmin = is_max then (m' <= m) else (m <= m')"; +parse thy "if a=b then a else b"; +parse thy "maxmin = is_max"; +parse thy "maxmin =!= is_max"; + ^^^--- geht nicht wegen fun-types *) + +"pbltyp --- maximum ---"; +val pbltyp = {given=["fixed_values (cs::bool list)"], + where_=["foldl (op &) True (map is_equality cs)", + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"], + find=["maximum m","values_for (ms::real list)"], + with_=["Ex_frees ((foldl (op &) True (r#rs)) & \ + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \ + \ --> m' <= m)))"], + relate=["max_relation r","additional_relations rs"]}:string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val org = ["fixed_values [R=(R::real)]", + "bound_variable a", "bound_variable b", "bound_variable alpha", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= pi}", + "maximum A", + "max_relation A=#2*a*b - a^^^#2", + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]; +val chkorg = map (the o (parse thy)) org; +val pbl = {given=["fixed_values [R=(R::real)]"],where_=[], + find=["maximum A","values_for [a,b]"], + with_=["EX alpha. A=#2*a*b - a^^^#2 & \ + \ a=#2*R*sin alpha & b=#2*R*cos alpha & \ + \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha & b=#2*R*cos alpha \ + \ --> A' <= A)"], + relate=["max_relation (A=#2*a*b - a^^^#2)", + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"] + }: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + +"met --- maximum_by_differentiation ---"; +val met = {given=["fixed_values (cs::bool list)","bound_variable v", + "domain {x::real. lower_bound <= x & x <= upper_bound}", + "approximation apx"], + where_=[], + find=["maximum m","values_for (ms::real list)", + "function_term t","max_argument mx"], + with_=["Ex_frees ((foldl (op &) True (rs::bool list)) & \ + \ (ALL m'. (subst (m,m') (foldl (op &) True rs) \ + \ --> m' <= m))) & \ + \m = (%v. t) mx & \ + \( ALL x. lower_bound <= x & x <= upper_bound \ + \ --> (%v. t) x <= m)"], + relate=["rs::bool list"]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) met; + + +"pbltyp --- make_fun ---"; +(* subproblem [(hd #relate root, equality), + (bound_variable formalization, bound_variable), + (tl #relate root, equalities)] *) +val pbltyp = {given=["equality e","bound_variable v", "equalities es"], + where_=[], + find=["function_term t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val pbl = {given=["equality (A=#2*a*b - a^^^#2)","bound_variable alpha", + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], + where_=[], + find=["function_term t"], + with_=[],relate=[]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + +"met --- make_explicit_and_substitute ---"; +val met = {given=["equality e","bound_variable v", "equalities es"], + where_=[], + find=["function_term t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkmet = ((map (the o (parse thy))) o ppc2list) met; +"met --- introduce_a_new_variable ---"; +val met = {given=["equality e","bound_variable v", "substitutions es"], + where_=[], + find=["function_term t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkmet = ((map (the o (parse thy))) o ppc2list) met; + + +"pbltyp --- max_of_fun_on_interval ---"; +val pbltyp = {given=["function_term t","bound_variable v", + "domain {x::real. lower_bound <= x & x <= upper_bound}"], + where_=[], + find=["maximums ms"], + with_=["ALL m. m : ms --> \ + \ (ALL x::real. lower_bound <= x & x <= upper_bound \ + \ --> (%v. t) x <= m)"], + relate=[]}: string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val pbl = {given=["function_term #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \ + \ (#2*R*sin alpha)^^^#2","bound_variable alpha", + "domain {x::real. #0 <= x & x <= pi}"],where_=[], + find=["maximums [#1234]"],with_=[],relate=[]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + + +(* pbltyp --- max_of_fun --- *) +(* +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; +val (SOME ct) = parse thy ; +atomty thy (term_of ct); +*) + + + + + + + + +(* --- 14.1.00 --- *) +"p.114"; +val org = {given=["[u=(#12::real)]"],where_=[], + find=["[a,(b::real)]"],with_=[], + relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"p.116"; +val org = {given=["[c=#10, h=(#4::real)]"],where_=[], + find=["[x,(y::real)]"],with_=[], + relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"p.117"; +val org = {given=["[r=#5]"],where_=[], + find=["[x,(y::real)]"],with_=[], + relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"#241"; +val org = {given=["[s=(#10::real)]"],where_=[], + find=["[p::real]"],with_=[], + relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; + +(* +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; +val (SOME ct) = parse thy ; +atomty thy (term_of ct); +*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp-oldscr.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp-oldscr.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,96 @@ +(*8.01: alte Scripts f"ur Extremwertaufgabe gesammelt*) + +(* Das erste Script aus dem Maximum-Beispiel. + parse erzeugt aus dem string 's' den + 'cterm 's' im Isabelle-Format (pretty-printing !)*) + +ML> ... +ML> val c = (the o (parse thy)) s; +val c = + "Script1 Maximum_value fix_ m_ rs_ v_ itv_ err_ = + let e_ = (hd o filter (Testvar m_)) rs_; + t_ = + if #1 < Length rs_ + then make_fun (R, [make, function], no_met) m_ v_ rs_ + else (Lhs o hd) rs_; + mx_ = + max_on_interval (R, [on_interval, max_of, function], + maximum_on_interval) t_ v_ itv_ + in find_vals (R, [find_values, tool], find_values) + mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm + +ML> set show_types; +ML> c; +val c = + "Script1 Maximum_value fix_::bool list m_::real rs_::bool list v_::real itv_::real set err_::bool = + let e_::bool = (hd o filter (Testvar m_)) rs_; + t_::real = + if (#1::real) < Length rs_ + then make_fun (R::ID, [make::ID, function::ID], no_met::ID) m_ v_ rs_ + else (Lhs o hd) rs_; + mx_::real = + max_on_interval (R, [on_interval::ID, max_of::ID, function], + maximum_on_interval::ID) t_ v_ itv_ + in find_vals (R, [find_values::ID, tool::ID], find_values) + mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm + + + +(* Die ersten 3 Scripts aus dem Maximum-Beispiel. + parse erzeugt aus dem string 's' den + 'cterm 's' im Isabelle-Format (pretty-printing !)*) + +ML> ... +ML> val c = (the o (parse thy)) s; +val c = + "Script maximum = + Input [Bool fix_, Real m_, BoolList rs_, Real v_, RealSet itv_, Bool err_] + Local [Bool e_, Real t_, Real mx_, RealList vs_] + Tacs [SEQU + [let e_ = (hd o filter (Testvar m_)) rs_ + in if #1 < Length rs_ + then Subproblem Spec (R, [make, function], no_met) + InOut [In m_, In v_, In rs_, Out t_] + else t_ := (Lhs o hd) rs_ ; + Subproblem Spec (R, [on_interval, max_of, function], + maximum_on_interval) + InOut [In t_, In v_, In itv_, In err_, Out mx_] ; + Subproblem Spec (R, [find_values, tool], find_values) + InOut [In mx_, In t_, In v_, In m_, In (dropWhile (op = e_) rs_), + Out vs_]]] + Return []" : cterm + +ML> ... +ML> val c = (the o (parse thy)) s; +val c = + "Script make_fun_by_new_variable = + Input [Real f_, Real v_, BoolList eqs_] + Local [Bool h_, BoolList es_, RealList vs_, Real v1_, Real v2_, Bool e1, + Bool e2_, BoolList s_1, BoolList s_2] + Tacs [SEQU + [let h_ = (hd o filter (Testvar m_)) eqs_; es_ = eqs_ -- [h_]; + vs_ = Var h_ -- [f_]; v1_ = Nth #1 vs_; v2_ = Nth #2 vs_; + e1_ = (hd o filter (Testvar v1_)) es_; + e2_ = (hd o filter (Testvar v2_)) es_ + in Subproblem Spec (R, [univar, equation], no_met) + InOut [In e1_, In v1_, Out s_1] ; + Subproblem Spec (R, [univar, equation], no_met) + InOut [In e2_, In v2_, Out s_2]], + Take (Bool h_) ; + Substitute [(v_1, (Rhs o hd) s_1), (v_2, (Rhs o hd) s_2)]] + Return [Currform]" : cterm + +ML> ... +ML> val c = (the o (parse thy)) s; +val c = + "Script make_fun_explicit = + Input [Real f_, Real v_, BoolList eqs_] + Local [Bool h_, Bool eq_, RealList vs_, Real v1_, BoolList ss_] + Tacs [SEQU + [let h_ = (hd o filter (Testvar m_)) eqs_; eq_ = hd (eqs_ -- [h_]); + vs_ = Var h_ -- [f_]; v1_ = hd (vs_ -- [v_]) + in Subproblem Spec (R, [univar, equation], no_met) + InOut [In eq_, In v1_, Out ss_]], + Take (Bool h_) ; Substitute [(v1_, (Rhs o hd) ss_)]] + Return [Currform]" : cterm +ML> diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp-scrpbl.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp-scrpbl.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,429 @@ +(* use"test-coil-kernel.sml"; + W.N.22.11.99 + +*) + +(* vvv--- geht nicht wegen fun-types +parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')"; +parse thy "if maxmin = is_max then (m' <= m) else (m <= m')"; +parse thy "if a=b then a else b"; +parse thy "maxmin = is_max"; +parse thy "maxmin =!= is_max"; + ^^^--- geht nicht wegen fun-types *) + +"pbltyp --- maximum ---"; +val pbltyp = {given=["fixedValues (cs::bool list)"], + where_=[(*"foldl (op &) True (map is_equality cs)", + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"*)], + find=["maximum m","values_for (ms::real list)"], + with_=[(*"Ex_frees ((foldl (op &) True (r#rs)) & \ + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \ + \ --> m' <= m)))"*)], + relate=["max_relation r","additionalRels rs"]}:string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val org = ["fixedValues [R=(R::real)]", + "boundVariable a","boundVariable b","boundVariable alpha", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= pi}", + "errorBound (eps = #1//#1000)", + "maximum A", + (*"max_relation A=#2*a*b - a^^^#2",*) + "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", + "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]", + "relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"]; +val chkorg = map (the o (parse thy)) org; +val pbl = {given=["fixedValues [R=(R::real)]"],where_=[], + find=["maximum A","values_for [a,b]"], + with_=[(* incompat.w. parse, ok with parseold + "EX alpha. A=#2*a*b - a^^^#2 & \ + \ a=#2*R*sin alpha & b=#2*R*cos alpha & \ + \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha \ + \ & b=#2*R*cos alpha \ + \ --> A' <= A)"*)], + relate=["relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"] + }: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + +"met --- maximum_by_differentiation ---"; +val met = {given=["fixedValues (cs::bool list)","boundVariable v", + "domain {x::real. lower_bound <= x & x<=upper_bound}", + "errorBound epsilon"], + where_=[], + find=["maximum m","valuesFor (ms::bool list)", + "function_term t","max_argument mx"], + with_=[(* incompat.w. parse, ok with parseold + "Ex_frees ((foldl (op &) True (mr#ars)) & \ + \ (ALL m'. (subst (m,m') (foldl (op &) True (mr#ars))\ + \ --> m' <= m))) & \ + \m = (%v. t) mx & \ + \( ALL x. lower_bound <= x & x <= upper_bound \ + \ --> (%v. t) x <= m)"*)], + relate=["max_relation mr", + "additionalRels ars"]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) met; + +"data --- maximum_by_differentiation ---"; +val met = {given=["fixedValues [R=(R::real)]","boundVariable alpha", + "domain {x::real. #0 <= x & x <= pi//#2}", + "errorBound (eps = #1//#1000)"], + where_=[], + find=["maximum A","valuesFor [a=Undef]", + "function_term t","max_argument mx"], + with_=[(* incompat.w. parse, ok with parseold + "EX b alpha. A = #2*a*b - a^^^#2 & \ + \ a = #2*R*sin alpha & \ + \ b = #2*R*cos alpha & \ + \ (ALL A'. A'= #2*a*b - a^^^#2 & \ + \ a = #2*R*sin alpha & \ + \ b = #2*R*cos alpha --> A' <= A) & \ + \ A = (%alpha. t) mx & \ + \ (ALL x. #0 <= x & x <= pi --> \ + \ (%alpha. t) x <= A)"*)], + relate=["max_relation mr", + "additionalRels ars"]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) met; + +val (SOME ct) = parseold thy "EX b. (EX alpha. A = #2*a*b - a^^^#2)"; + +"pbltyp --- make_fun ---"; +(* subproblem [(hd #relate root, equality), + (boundVariable formalization, boundVariable), + (tl #relate root, equalities)] *) +val pbltyp = {given=["equality e","boundVariable v", "equalities es"], + where_=[], + find=["functionTerm t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val pbl = {given=["equality (A=#2*a*b - a^^^#2)","boundVariable alpha", + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"], + where_=[], + find=["functionTerm t"], + with_=[],relate=[]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + +"met --- make_explicit_and_substitute ---"; +val met = {given=["equality e","boundVariable v", "equalities es"], + where_=[], + find=["functionTerm t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkmet = ((map (the o (parse thy))) o ppc2list) met; +"met --- introduce_a_new_variable ---"; +val met = {given=["equality e","boundVariable v", "substitutions es"], + where_=[], + find=["functionTerm t"],with_=[(*???*)], + relate=[(*???*)]}: string ppc; +val chkmet = ((map (the o (parse thy))) o ppc2list) met; + + +"pbltyp --- max_of_fun_on_interval ---"; +val pbltyp = {given=["functionTerm t","boundVariable v", + "domain {x::real. lower_bound <= x & x <= upper_bound}"], + where_=[], + find=["maximums ms"], + with_=[(* incompat.w. parse, ok with parseold + "ALL m. m : ms --> \ + \ (ALL x::real. lower_bound <= x & x <= upper_bound \ + \ --> (%v. t) x <= m)"*)], + relate=[]}: string ppc; +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp; +"coil"; +val pbl = {given=["functionTerm (f = #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \ + \ (#2*R*sin alpha)^^^#2)","boundVariable alpha", + "domain {x::real. #0 <= x & x <= pi}"],where_=[], + find=["maximums [#1234]"],with_=[],relate=[]}: string ppc; +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl; + + +(* pbltyp --- max_of_fun --- *) +(* +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc; +val (SOME ct) = parse thy ; +atomty (term_of ct); +*) + + +(* --- 14.1.00 ev. nicht ganz up to date bzg. oberem --- *) +"p.114"; +val org = {given=["[u=(#12::real)]"],where_=[], + find=["[a,(b::real)]"],with_=[], + relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"p.116"; +val org = {given=["[c=#10, h=(#4::real)]"],where_=[], + find=["[x,(y::real)]"],with_=[], + relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"p.117"; +val org = {given=["[r=#5]"],where_=[], + find=["[x,(y::real)]"],with_=[], + relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; +"#241"; +val org = {given=["[s=(#10::real)]"],where_=[], + find=["[p::real]"],with_=[], + relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc; +val chkorg = ((map (the o (parse thy))) o ppc2list) org; + + + +(* -------------- coil-kernel -------------- vor 19.1.00 *) +(* --- subproblem: make-function-by-subst ~~~~~~~~~~~ *) +(* --- subproblem: max-of-function *) +(* --- subproblem: derivative *) +(* --- subproblem: tan-quadrat-equation *) +"-------------- coil-kernel --------------"; +val origin = ["A=#2*a*b - a^^^#2", + "a::real","b::real","{x. #0 real","maxs::real set"]; +val with_ = [(* incompat.w. parse, ok with parseold + "maxs = {m. low < m & m < high & \ + \ (m is_local_max_of (%bdv. f))}"*)]; +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_); +val givens = map (the o (parse thy)) given; + +"------- 1.1 -------"; +(* 5.3.00 +val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2", + "a::real","{x. #0 val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = + specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree; + +> val ct = "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2, b=#2*R*cos alpha]"; +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; +*) + +(* --- incomplete input --- +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = + specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree; + +> val ct = "[R=(R::real)]"; +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; + +> val ct = "R=(R::real)"; +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt; + +> val ct = "(R::real)"; +> specify nxt p c pt; +*) + + +" #################################################### "; +" test do_ specify "; +" #################################################### "; + + +val cts = ["fixedValues [R=(R::real)]", + "boundVariable a", "boundVariable b", + "boundVariable alpha", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= #2*R}", + "domain {x::real. #0 <= x & x <= pi//#2}", + "errorBound (eps=#1//#1000)", + "maximum A","valuesFor [a=Undef]", + (*"functionTerm t","max_argument mx", *) + "max_relation (A=#2*a*b - a^^^#2)", + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]", + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]", + "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"]; +val (dI',pI',mI')= + ("DiffAppl.thy",["DiffAppl.thy","test_maximum"],e_metID); +val p = e_pos'; val c = []; + +val (mI,m) = ("Init_Proof",Init_Proof (cts, (dI',pI',mI'))); +val (pst as (sc,pt,cl):pstate) = (EmptyScr, e_ptree, []); +val (p,_,f,nxt,_,(_,pt,_)) = do_ (mI,m) p c pst; +(*val nxt = ("Add_Given",Add_Given "fixedValues [R = R]")*) + +val (p,_,Form' (PpcKF (_,_,ppc)),nxt,_,(_,pt,_)) = + do_ nxt p c (EmptyScr,pt,[]); +(*val nxt = ("Add_Given",Add_Given "boundVariable a") *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,221 @@ +(* tools for applications of differetiation + use"DiffApp.ML"; + use"Knowledge/DiffApp.ML"; + use"../Knowledge/DiffApp.ML"; + + +WN.6.5.03: old decisions in this file partially are being changed + in a quick-and-dirty way to make scripts run: Maximum_value, + Make_fun_by_new_variable, Make_fun_by_explicit. +found to be reconsidered: +- descriptions (Descript.thy) +- penv: really need term list; or just rerun the whole example with num/var +- mk_arg, itms2args ... env in script different from penv ? +- L = SubProblem eq ... show some vars on the worksheet ? (other means for + referencing are labels (no on worksheet)) + +WN.6.5.03 quick-and-dirty: mk_arg, itms2args just make most convenient env + from penv as is. + *) + + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("DiffApp.thy",DiffApp.thy)]); + +val eval_rls = prep_rls( + Rls {id="eval_rls",preconds = [], rew_ord = ("termlessI",termlessI), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + Thm ("and_commute",num_str and_commute), + Thm ("or_commute",num_str or_commute), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Tools.matches",eval_matches "") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +ruleset' := overwritelthy thy + (!ruleset', + [("eval_rls",Atools_erls)(*FIXXXME:del with rls.rls'*) + ]); + + +(** problem types **) + +store_pbt + (prep_pbt DiffApp.thy "pbl_fun_max" [] e_pblID + (["maximum_of","function"], + [("#Given" ,["fixedValues fix_"]), + ("#Find" ,["maximum m_","valuesFor vs_"]), + ("#Relate",["relations rs_"]) + ], + e_rls, NONE, [])); + +store_pbt + (prep_pbt DiffApp.thy "pbl_fun_make" [] e_pblID + (["make","function"]:pblID, + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), + ("#Find" ,["functionEq f_1_"]) + ], + e_rls, NONE, [])); +store_pbt + (prep_pbt DiffApp.thy "pbl_fun_max_expl" [] e_pblID + (["by_explicit","make","function"]:pblID, + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), + ("#Find" ,["functionEq f_1_"]) + ], + e_rls, NONE, [["DiffApp","make_fun_by_explicit"]])); +store_pbt + (prep_pbt DiffApp.thy "pbl_fun_max_newvar" [] e_pblID + (["by_new_variable","make","function"]:pblID, + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), + (*WN.12.5.03: precond for distinction still missing*) + ("#Find" ,["functionEq f_1_"]) + ], + e_rls, NONE, [["DiffApp","make_fun_by_new_variable"]])); + +store_pbt + (prep_pbt DiffApp.thy "pbl_fun_max_interv" [] e_pblID + (["on_interval","maximum_of","function"]:pblID, + [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"]), + (*WN.12.5.03: precond for distinction still missing*) + ("#Find" ,["maxArgument v_0_"]) + ], + e_rls, NONE, [])); + +store_pbt + (prep_pbt DiffApp.thy "pbl_tool" [] e_pblID + (["tool"]:pblID, + [], + e_rls, NONE, [])); + +store_pbt + (prep_pbt DiffApp.thy "pbl_tool_findvals" [] e_pblID + (["find_values","tool"]:pblID, + [("#Given" ,["maxArgument ma_","functionEq f_","boundVariable v_"]), + ("#Find" ,["valuesFor vls_"]), + ("#Relate",["additionalRels rs_"]) + ], + e_rls, NONE, [])); + + +(** methods, scripts not yet implemented **) + +store_met + (prep_met Diff.thy "met_diffapp" [] e_metID + (["DiffApp"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls = Atools_erls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); +store_met + (prep_met DiffApp.thy "met_diffapp_max" [] e_metID + (["DiffApp","max_by_calculus"]:metID, + [("#Given" ,["fixedValues fix_","maximum m_","relations rs_", + "boundVariable v_","interval itv_","errorBound err_"]), + ("#Find" ,["valuesFor vs_"]), + ("#Relate",[]) + ], + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls, + crls = eval_rls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, + "Script Maximum_value(fix_::bool list)(m_::real) (rs_::bool list)\ + \ (v_::real) (itv_::real set) (err_::bool) = \ + \ (let e_ = (hd o (filterVar m_)) rs_; \ + \ t_ = (if 1 < length_ rs_ \ + \ then (SubProblem (DiffApp_,[make,function],[no_met])\ + \ [real_ m_, real_ v_, bool_list_ rs_])\ + \ else (hd rs_)); \ + \ (mx_::real) = SubProblem(DiffApp_,[on_interval,maximum_of,function],\ + \ [DiffApp,max_on_interval_by_calculus])\ + \ [bool_ t_, real_ v_, real_set_ itv_]\ + \ in ((SubProblem (DiffApp_,[find_values,tool],[Isac,find_values]) \ + \ [real_ mx_, real_ (Rhs t_), real_ v_, real_ m_, \ + \ bool_list_ (dropWhile (ident e_) rs_)])::bool list))" + )); +store_met + (prep_met DiffApp.thy "met_diffapp_funnew" [] e_metID + (["DiffApp","make_fun_by_new_variable"]:metID, + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), + ("#Find" ,["functionEq f_1_"]) + ], + {rew_ord'="tless_true",rls'=eval_rls,srls=list_rls,prls=e_rls, + calc=[], crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)}, + "Script Make_fun_by_new_variable (f_::real) (v_::real) \ + \ (eqs_::bool list) = \ + \(let h_ = (hd o (filterVar f_)) eqs_; \ + \ es_ = dropWhile (ident h_) eqs_; \ + \ vs_ = dropWhile (ident f_) (Vars h_); \ + \ v_1 = nth_ 1 vs_; \ + \ v_2 = nth_ 2 vs_; \ + \ e_1 = (hd o (filterVar v_1)) es_; \ + \ e_2 = (hd o (filterVar v_2)) es_; \ + \ (s_1::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\ + \ [bool_ e_1, real_ v_1]);\ + \ (s_2::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\ + \ [bool_ e_2, real_ v_2])\ + \in Substitute [(v_1 = (rhs o hd) s_1),(v_2 = (rhs o hd) s_2)] h_)" +)); +store_met +(prep_met DiffApp.thy "met_diffapp_funexp" [] e_metID +(["DiffApp","make_fun_by_explicit"]:metID, + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]), + ("#Find" ,["functionEq f_1_"]) + ], + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls, + crls = eval_rls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, + "Script Make_fun_by_explicit (f_::real) (v_::real) \ + \ (eqs_::bool list) = \ + \ (let h_ = (hd o (filterVar f_)) eqs_; \ + \ e_1 = hd (dropWhile (ident h_) eqs_); \ + \ vs_ = dropWhile (ident f_) (Vars h_); \ + \ v_1 = hd (dropWhile (ident v_) vs_); \ + \ (s_1::bool list)=(SubProblem(DiffApp_,[univariate,equation],[no_met])\ + \ [bool_ e_1, real_ v_1])\ + \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)" + )); +store_met + (prep_met DiffApp.thy "met_diffapp_max_oninterval" [] e_metID + (["DiffApp","max_on_interval_by_calculus"]:metID, + [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"(*, + "errorBound err_"*)]), + ("#Find" ,["maxArgument v_0_"]) + ], + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls, + crls = eval_rls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, + "empty_script" + )); +store_met + (prep_met DiffApp.thy "met_diffapp_findvals" [] e_metID + (["DiffApp","find_values"]:metID, + [], + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls, + crls = eval_rls, nrls=norm_Rational(*, + asm_rls=[],asm_thm=[]*)}, + "empty_script")); + +val list_rls = append_rls "list_rls" list_rls + [Thm ("filterVar_Const", num_str filterVar_Const), + Thm ("filterVar_Nil", num_str filterVar_Nil) + ]; +ruleset' := overwritelthy thy (!ruleset', + [("list_rls",list_rls) + ]); + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,105 @@ +(* = DiffAppl.ML + +++ outcommented tests +*) + + +theory' := overwritel (!theory', [("DiffAppl.thy",DiffAppl.thy)]); + +(* +> get_pbt ["DiffAppl.thy","maximum_of","function"]; +> get_met ("Script.thy","max_on_interval_by_calculus"); +> !pbltypes; + *) +pbltypes:= overwritel (!pbltypes, +[ + prep_pbt DiffAppl.thy + (["DiffAppl.thy","maximum_of","function"], + [("#Given" ,"fixedValues fix_"), + ("#Find" ,"maximum m_"), + ("#Find" ,"valuesFor vs_"), + ("#Relate","relations rs_") (*, + ("#where" ,"foldl (op&) True (map (Not o ((op<=) #0) o Rhs) fix_)"), + ("#with" ,"Ex_frees ((foldl (op &) True rs_) & \ + \ (ALL m'. (subst (m_,m') (foldl (op &) True rs_) \ + \ --> m' <= m_)))") *) + ]), + + prep_pbt DiffAppl.thy + (["DiffAppl.thy","make","function"]:pblID, + [("#Given" ,"functionOf f_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"equalities eqs_"), + ("#Find" ,"functionTerm f_0_") + ]), + + prep_pbt DiffAppl.thy + (["DiffAppl.thy","on_interval","maximum_of","function"]:pblID, + [("#Given" ,"functionTerm t_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"interval itv_"), + ("#Find" ,"maxArgument v_0_") + ]), + + prep_pbt DiffAppl.thy + (["DiffAppl.thy","find_values","tool"]:pblID, + [("#Given" ,"maxArgument ma_"), + ("#Given" ,"functionTerm f_"), + ("#Given" ,"boundVariable v_"), + ("#Find" ,"valuesFor vls_"), + ("#Relate","additionalRels rs_") + ]) +]); + + +methods:= overwritel (!methods, +[ + (("DiffAppl.thy","max_by_calculus"):metID, + {ppc = prep_met DiffAppl.thy + [("#Given" ,"fixedValues fix_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"interval itv_"), + ("#Given" ,"errorBound err_"), + ("#Find" ,"maximum m_"), + ("#Find" ,"valuesFor vs_"), + ("#Relate","relations rs_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met), + + (("DiffAppl.thy","make_fun_by_new_variable"):metID, + {ppc = prep_met DiffAppl.thy + [("#Given" ,"functionOf f_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"equalities eqs_"), + ("#Find" ,"functionTerm f_0_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met), + + (("DiffAppl.thy","make_fun_by_explicit"):metID, + {ppc = prep_met DiffAppl.thy + [("#Given" ,"functionOf f_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"equalities eqs_"), + ("#Find" ,"functionTerm f_0_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met), + + (("DiffAppl.thy","max_on_interval_by_calculus"):metID, + {ppc = prep_met DiffAppl.thy + [("#Given" ,"functionTerm t_"), + ("#Given" ,"boundVariable v_"), + ("#Given" ,"interval itv_"), + ("#Given" ,"errorBound err_"), + ("#Find" ,"maxArgument v_0_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met), + + (("DiffAppl.thy","find_values"):metID, + {ppc = prep_met DiffAppl.thy + [], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met) +]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/DiffApp.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/DiffApp.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,40 @@ +(* application of differential calculus + use_thy_only"../Knowledge/DiffApp"; + use_thy_only"DiffApp"; + + +*) + + +DiffApp = Diff + + +consts + + Maximum'_value + :: "[bool list,real,bool list,real,real set,bool,\ + \ bool list] => bool list" + ("((Script Maximum'_value (_ _ _ _ _ _ =))// (_))" 9) + + Make'_fun'_by'_new'_variable + :: "[real,real,bool list, \ + \ bool] => bool" + ("((Script Make'_fun'_by'_new'_variable (_ _ _ =))// \ + \(_))" 9) + Make'_fun'_by'_explicit + :: "[real,real,bool list, \ + \ bool] => bool" + ("((Script Make'_fun'_by'_explicit (_ _ _ =))// \ + \(_))" 9) + + dummy :: real + +(*for script Maximum_value*) + filterVar :: "[real, 'a list] => 'a list" + +(*primrec*)rules + filterVar_Nil "filterVar v [] = []" + filterVar_Const "filterVar v (x#xs) = \ + \(if (v mem (Vars x)) then x#(filterVar v xs) \ + \ else filterVar v xs) " + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/EqSystem.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/EqSystem.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,673 @@ +(* tools for systems of equations over the reals + author: Walther Neuper 050905, 08:51 + (c) due to copyright terms + +use"Knowledge/EqSystem.ML"; +use"EqSystem.ML"; + +remove_thy"EqSystem"; +use_thy"Knowledge/Isac"; +*) + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("EqSystem.thy",EqSystem.thy)]); + +(** eval functions **) + +(*certain variables of a given list occur _all_ in a term + args: all: ..variables, which are under consideration (eg. the bound vars) + vs: variables which must be in t, + and none of the others in all must be in t + t: the term under consideration + *) +fun occur_exactly_in vs all t = + let fun occurs_in' a b = occurs_in b a + in foldl and_ (true, map (occurs_in' t) vs) + andalso not (foldl or_ (false, map (occurs_in' t) (all \\ vs))) + end; + +(*("occur_exactly_in", ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in "#eval_occur_exactly_in_"))*) +fun eval_occur_exactly_in _ "EqSystem.occur'_exactly'_in" + (p as (Const ("EqSystem.occur'_exactly'_in",_) + $ vs $ all $ t)) _ = + if occur_exactly_in (isalist2list vs) (isalist2list all) t + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_occur_exactly_in _ _ _ _ = NONE; + +calclist':= +overwritel (!calclist', + [("occur_exactly_in", + ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in "#eval_occur_exactly_in_")) + ]); + + +(** rewrite order 'ord_simplify_System' **) + +(* order wrt. several linear (i.e. without exponents) variables "c","c_2",.. + which leaves the monomials containing c, c_2,... at the end of an Integral + and puts the c, c_2,... rightmost within a monomial. + + WN050906 this is a quick and dirty adaption of ord_make_polynomial_in, + which was most adequate, because it uses size_of_term*) +(**) +local (*. for simplify_System .*) +(**) +open Term; (* for type order = EQUAL | LESS | GREATER *) + +fun pr_ord EQUAL = "EQUAL" + | pr_ord LESS = "LESS" + | pr_ord GREATER = "GREATER"; + +fun dest_hd' (Const (a, T)) = (((a, 0), T), 0) + | dest_hd' (Free (ccc, T)) = + (case explode ccc of + "c"::[] => ((("|||||||||||||||||||||", 0), T), 1)(*greatest string WN*) + | "c"::"_"::_ => ((("|||||||||||||||||||||", 0), T), 1) + | _ => (((ccc, 0), T), 1)) + | dest_hd' (Var v) = (v, 2) + | dest_hd' (Bound i) = ((("", i), dummyT), 3) + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); + +fun size_of_term' (Free (ccc, _)) = + (case explode ccc of (*WN0510 hack for the bound variables*) + "c"::[] => 1000 + | "c"::"_"::is => 1000 * ((str2int o implode) is) + | _ => 1) + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body + | size_of_term' (f$t) = size_of_term' f + size_of_term' t + | size_of_term' _ = 1; + +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) + | term_ord' pr thy (t, u) = + (if pr then + let + val (f, ts) = strip_comb t and (g, us) = strip_comb u; + val _=writeln("t= f@ts= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ + (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\""); + val _=writeln("u= g@us= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ + (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\""); + val _=writeln("size_of_term(t,u)= ("^ + (string_of_int(size_of_term' t))^", "^ + (string_of_int(size_of_term' u))^")"); + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); + val _=writeln("terms_ord(ts,us) = "^ + ((pr_ord o terms_ord str false)(ts,us))); + val _=writeln("-------"); + in () end + else (); + case int_ord (size_of_term' t, size_of_term' u) of + EQUAL => + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) + | ord => ord) + end + | ord => ord) +and hd_ord (f, g) = (* ~ term.ML *) + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, + dest_hd' g) +and terms_ord str pr (ts, us) = + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); +(**) +in +(**) +(*WN0510 for preliminary use in eval_order_system, see case-study mat-eng.tex +fun ord_simplify_System_rev (pr:bool) thy subst tu = + (term_ord' pr thy (Library.swap tu) = LESS);*) + +(*for the rls's*) +fun ord_simplify_System (pr:bool) thy subst tu = + (term_ord' pr thy tu = LESS); +(**) +end; +(**) +rew_ord' := overwritel (!rew_ord', +[("ord_simplify_System", ord_simplify_System false thy) + ]); + + +(** rulesets **) + +(*.adapted from 'order_add_mult_in' by just replacing the rew_ord.*) +val order_add_mult_System = + Rls{id = "order_add_mult_System", preconds = [], + rew_ord = ("ord_simplify_System", + ord_simplify_System false Integrate.thy), + erls = e_rls,srls = Erls, calc = [], + rules = [Thm ("real_mult_commute",num_str real_mult_commute), + (* z * w = w * z *) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) + Thm ("real_mult_assoc",num_str real_mult_assoc), + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) + Thm ("real_add_commute",num_str real_add_commute), + (*z + w = w + z*) + Thm ("real_add_left_commute",num_str real_add_left_commute), + (*x + (y + z) = y + (x + z)*) + Thm ("real_add_assoc",num_str real_add_assoc) + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) + ], + scr = EmptyScr}:rls; + +(*.adapted from 'norm_Rational' by + #1 using 'ord_simplify_System' in 'order_add_mult_System' + #2 NOT using common_nominator_p .*) +val norm_System_noadd_fractions = + Rls {id = "norm_System_noadd_fractions", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [(*sequence given by operator precedence*) + Rls_ discard_minus, + Rls_ powers, + Rls_ rat_mult_divide, + Rls_ expand, + Rls_ reduce_0_1_2, + Rls_ (*order_add_mult #1*) order_add_mult_System, + Rls_ collect_numerals, + (*Rls_ add_fractions_p, #2*) + Rls_ cancel_p + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; +(*.adapted from 'norm_Rational' by + *1* using 'ord_simplify_System' in 'order_add_mult_System'.*) +val norm_System = + Rls {id = "norm_System", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [(*sequence given by operator precedence*) + Rls_ discard_minus, + Rls_ powers, + Rls_ rat_mult_divide, + Rls_ expand, + Rls_ reduce_0_1_2, + Rls_ (*order_add_mult *1*) order_add_mult_System, + Rls_ collect_numerals, + Rls_ add_fractions_p, + Rls_ cancel_p + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +(*.simplify an equational system BEFORE solving it such that parentheses are + ( ((u0*v0)*w0) + ( ((u1*v1)*w1) * c + ... +((u4*v4)*w4) * c_4 ) ) +ATTENTION: works ONLY for bound variables c, c_1, c_2, c_3, c_4 :ATTENTION + This is a copy from 'make_ratpoly_in' with respective reductions: + *0* expand the term, ie. distribute * and / over + + *1* ord_simplify_System instead of termlessI + *2* no add_fractions_p (= common_nominator_p_rls !) + *3* discard_parentheses only for (.*(.*.)) + analoguous to simplify_Integral .*) +val simplify_System_parenthesized = + Seq {id = "simplify_System_parenthesized", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, calc = [], + rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib), + (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*) + Thm ("real_add_divide_distrib",num_str real_add_divide_distrib), + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*) + (*^^^^^ *0* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*) + Rls_ norm_Rational_noadd_fractions(**2**), + Rls_ (*order_add_mult_in*) norm_System_noadd_fractions (**1**), + Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)) + (*Rls_ discard_parentheses *3**), + Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*) + Rls_ separate_bdv2, + Calc ("HOL.divide" ,eval_cancel "#divide_") + ], + scr = EmptyScr}:rls; + +(*.simplify an equational system AFTER solving it; + This is a copy of 'make_ratpoly_in' with the differences + *1* ord_simplify_System instead of termlessI .*) +(*TODO.WN051031 ^^^^^^^^^^ should be in EACH rls contained *) +val simplify_System = + Seq {id = "simplify_System", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, calc = [], + rules = [Rls_ norm_Rational, + Rls_ (*order_add_mult_in*) norm_System (**1**), + Rls_ discard_parentheses, + Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*) + Rls_ separate_bdv2, + Calc ("HOL.divide" ,eval_cancel "#divide_") + ], + scr = EmptyScr}:rls; +(* +val simplify_System = + append_rls "simplify_System" simplify_System_parenthesized + [Thm ("sym_real_add_assoc", num_str (real_add_assoc RS sym))]; +*) + +val isolate_bdvs = + Rls {id="isolate_bdvs", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = append_rls "erls_isolate_bdvs" e_rls + [(Calc ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in + "#eval_occur_exactly_in_")) + ], + srls = Erls, calc = [], + rules = [Thm ("commute_0_equality", + num_str commute_0_equality), + Thm ("separate_bdvs_add", num_str separate_bdvs_add), + Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)], + scr = EmptyScr}; +val isolate_bdvs_4x4 = + Rls {id="isolate_bdvs_4x4", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = append_rls + "erls_isolate_bdvs_4x4" e_rls + [Calc ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in "#eval_occur_exactly_in_"), + Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Atools.some'_occur'_in", + eval_some_occur_in "#some_occur_in_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false) + ], + srls = Erls, calc = [], + rules = [Thm ("commute_0_equality", + num_str commute_0_equality), + Thm ("separate_bdvs0", num_str separate_bdvs0), + Thm ("separate_bdvs_add1", num_str separate_bdvs_add1), + Thm ("separate_bdvs_add1", num_str separate_bdvs_add2), + Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)], + scr = EmptyScr}; + +(*.order the equations in a system such, that a triangular system (if any) + appears as [..c_4 = .., ..., ..., ..c_1 + ..c_2 + ..c_3 ..c_4 = ..].*) +val order_system = + Rls {id="order_system", preconds = [], + rew_ord = ("ord_simplify_System", + ord_simplify_System false thy), + erls = Erls, srls = Erls, calc = [], + rules = [Thm ("order_system_NxN", num_str order_system_NxN) + ], + scr = EmptyScr}; + +val prls_triangular = + Rls {id="prls_triangular", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = Rls {id="erls_prls_triangular", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = Erls, srls = Erls, calc = [], + rules = [(*for precond nth_Cons_ ...*) + Calc ("op <",eval_equ "#less_"), + Calc ("op +", eval_binop "#add_") + (*immediately repeated rewrite pushes + '+' into precondition !*) + ], + scr = EmptyScr}, + srls = Erls, calc = [], + rules = [Thm ("nth_Cons_",num_str nth_Cons_), + Calc ("op +", eval_binop "#add_"), + Thm ("nth_Nil_",num_str nth_Nil_), + Thm ("tl_Cons",num_str tl_Cons), + Thm ("tl_Nil",num_str tl_Nil), + Calc ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in + "#eval_occur_exactly_in_") + ], + scr = EmptyScr}; + +(*WN060914 quickly created for 4x4; + more similarity to prls_triangular desirable*) +val prls_triangular4 = + Rls {id="prls_triangular4", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = Rls {id="erls_prls_triangular4", preconds = [], + rew_ord = ("e_rew_ord", e_rew_ord), + erls = Erls, srls = Erls, calc = [], + rules = [(*for precond nth_Cons_ ...*) + Calc ("op <",eval_equ "#less_"), + Calc ("op +", eval_binop "#add_") + (*immediately repeated rewrite pushes + '+' into precondition !*) + ], + scr = EmptyScr}, + srls = Erls, calc = [], + rules = [Thm ("nth_Cons_",num_str nth_Cons_), + Calc ("op +", eval_binop "#add_"), + Thm ("nth_Nil_",num_str nth_Nil_), + Thm ("tl_Cons",num_str tl_Cons), + Thm ("tl_Nil",num_str tl_Nil), + Calc ("EqSystem.occur'_exactly'_in", + eval_occur_exactly_in + "#eval_occur_exactly_in_") + ], + scr = EmptyScr}; + +ruleset' := +overwritelthy thy + (!ruleset', +[("simplify_System_parenthesized", prep_rls simplify_System_parenthesized), + ("simplify_System", prep_rls simplify_System), + ("isolate_bdvs", prep_rls isolate_bdvs), + ("isolate_bdvs_4x4", prep_rls isolate_bdvs_4x4), + ("order_system", prep_rls order_system), + ("order_add_mult_System", prep_rls order_add_mult_System), + ("norm_System_noadd_fractions", prep_rls norm_System_noadd_fractions), + ("norm_System", prep_rls norm_System) + ]); + + +(** problems **) + +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys" [] e_pblID + (["system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Find" ,["solution ss___"](*___ is copy-named*)) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "solveSystem es_ vs_", + [])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin" [] e_pblID + (["linear", "system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + (*TODO.WN050929 check linearity*) + ("#Find" ,["solution ss___"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "solveSystem es_ vs_", + [])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2" [] e_pblID + (["2x2", "linear", "system"], + (*~~~~~~~~~~~~~~~~~~~~~~~~~*) + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" ,["length_ (es_:: bool list) = 2", "length_ vs_ = 2"]), + ("#Find" ,["solution ss___"]) + ], + append_rls "prls_2x2_linear_system" e_rls + [Thm ("length_Cons_",num_str length_Cons_), + Thm ("length_Nil_",num_str length_Nil_), + Calc ("op +", eval_binop "#add_"), + Calc ("op =",eval_equal "#equal_") + ], + SOME "solveSystem es_ vs_", + [])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_tri" [] e_pblID + (["triangular", "2x2", "linear", "system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" , + ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))", + " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]), + ("#Find" ,["solution ss___"]) + ], + prls_triangular, + SOME "solveSystem es_ vs_", + [["EqSystem","top_down_substitution","2x2"]])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_norm" [] e_pblID + (["normalize", "2x2", "linear", "system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Find" ,["solution ss___"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "solveSystem es_ vs_", + [["EqSystem","normalize","2x2"]])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_3x3" [] e_pblID + (["3x3", "linear", "system"], + (*~~~~~~~~~~~~~~~~~~~~~~~~~*) + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" ,["length_ (es_:: bool list) = 3", "length_ vs_ = 3"]), + ("#Find" ,["solution ss___"]) + ], + append_rls "prls_3x3_linear_system" e_rls + [Thm ("length_Cons_",num_str length_Cons_), + Thm ("length_Nil_",num_str length_Nil_), + Calc ("op +", eval_binop "#add_"), + Calc ("op =",eval_equal "#equal_") + ], + SOME "solveSystem es_ vs_", + [])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4" [] e_pblID + (["4x4", "linear", "system"], + (*~~~~~~~~~~~~~~~~~~~~~~~~~*) + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" ,["length_ (es_:: bool list) = 4", "length_ vs_ = 4"]), + ("#Find" ,["solution ss___"]) + ], + append_rls "prls_4x4_linear_system" e_rls + [Thm ("length_Cons_",num_str length_Cons_), + Thm ("length_Nil_",num_str length_Nil_), + Calc ("op +", eval_binop "#add_"), + Calc ("op =",eval_equal "#equal_") + ], + SOME "solveSystem es_ vs_", + [])); +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_tri" [] e_pblID + (["triangular", "4x4", "linear", "system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" , (*accepts missing variables up to diagional form*) + ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))", + "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))", + "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))", + "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))" + ]), + ("#Find" ,["solution ss___"]) + ], + append_rls "prls_tri_4x4_lin_sys" prls_triangular + [Calc ("Atools.occurs'_in",eval_occurs_in "")], + SOME "solveSystem es_ vs_", + [["EqSystem","top_down_substitution","4x4"]])); + +store_pbt + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_norm" [] e_pblID + (["normalize", "4x4", "linear", "system"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + (*length_ is checked 1 level above*) + ("#Find" ,["solution ss___"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "solveSystem es_ vs_", + [["EqSystem","normalize","4x4"]])); + + +(* show_ptyps(); + *) + +(** methods **) + +store_met + (prep_met EqSystem.thy "met_eqsys" [] e_metID + (["EqSystem"], + [], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, + "empty_script" + )); +store_met + (prep_met EqSystem.thy "met_eqsys_topdown" [] e_metID + (["EqSystem","top_down_substitution"], + [], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, + "empty_script" + )); +store_met + (prep_met EqSystem.thy "met_eqsys_topdown_2x2" [] e_metID + (["EqSystem","top_down_substitution","2x2"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" , + ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))", + " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]), + ("#Find" ,["solution ss___"]) + ], + {rew_ord'="ord_simplify_System", rls' = Erls, calc = [], + srls = append_rls "srls_top_down_2x2" e_rls + [Thm ("hd_thm",num_str hd_thm), + Thm ("tl_Cons",num_str tl_Cons), + Thm ("tl_Nil",num_str tl_Nil) + ], + prls = prls_triangular, crls = Erls, nrls = Erls}, +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ +\ (let e1__ = Take (hd es_); \ +\ e1__ = ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ isolate_bdvs False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System False))) e1__; \ +\ e2__ = Take (hd (tl es_)); \ +\ e2__ = ((Substitute [e1__]) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ isolate_bdvs False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System False))) e2__; \ +\ es__ = Take [e1__, e2__] \ +\ in (Try (Rewrite_Set order_system False)) es__)" +(*--------------------------------------------------------------------------- + this script does NOT separate the equations as abolve, + but it does not yet work due to preliminary script-interpreter, + see eqsystem.sml 'script [EqSystem,top_down_substitution,2x2] Vers.2' + +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ +\ (let es__ = Take es_; \ +\ e1__ = hd es__; \ +\ e2__ = hd (tl es__); \ +\ es__ = [e1__, Substitute [e1__] e2__] \ +\ in ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))] \ +\ isolate_bdvs False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System False))) es__)" +---------------------------------------------------------------------------*) + )); +store_met + (prep_met EqSystem.thy "met_eqsys_norm" [] e_metID + (["EqSystem","normalize"], + [], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, + "empty_script" + )); +store_met + (prep_met EqSystem.thy "met_eqsys_norm_2x2" [] e_metID + (["EqSystem","normalize","2x2"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Find" ,["solution ss___"])], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = append_rls "srls_normalize_2x2" e_rls + [Thm ("hd_thm",num_str hd_thm), + Thm ("tl_Cons",num_str tl_Cons), + Thm ("tl_Nil",num_str tl_Nil) + ], + prls = Erls, crls = Erls, nrls = Erls}, +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ +\ (let es__ = ((Try (Rewrite_Set norm_Rational False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ isolate_bdvs False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set order_system False))) es_ \ +\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \ +\ [bool_list_ es__, real_list_ vs_]))" + )); + +(*this is for nth_ only*) +val srls = Rls {id="srls_normalize_4x4", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls + [(*for asm in nth_Cons_ ...*) + Calc ("op <",eval_equ "#less_"), + (*2nd nth_Cons_ pushes n+-1 into asms*) + Calc("op +", eval_binop "#add_") + ], + srls = Erls, calc = [], + rules = [Thm ("nth_Cons_",num_str nth_Cons_), + Calc("op +", eval_binop "#add_"), + Thm ("nth_Nil_",num_str nth_Nil_)], + scr = EmptyScr}; +store_met + (prep_met EqSystem.thy "met_eqsys_norm_4x4" [] e_metID + (["EqSystem","normalize","4x4"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Find" ,["solution ss___"])], + {rew_ord'="tless_true", rls' = Erls, calc = [], + srls = append_rls "srls_normalize_4x4" srls + [Thm ("hd_thm",num_str hd_thm), + Thm ("tl_Cons",num_str tl_Cons), + Thm ("tl_Nil",num_str tl_Nil) + ], + prls = Erls, crls = Erls, nrls = Erls}, +(*GOON met ["EqSystem","normalize","4x4"] @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ +\ (let es__ = \ +\ ((Try (Rewrite_Set norm_Rational False)) @@ \ +\ (Repeat (Rewrite commute_0_equality False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ +\ isolate_bdvs_4x4 False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \ +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set order_system False))) es_ \ +\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \ +\ [bool_list_ es__, real_list_ vs_]))" +)); +store_met +(prep_met EqSystem.thy "met_eqsys_topdown_4x4" [] e_metID + (["EqSystem","top_down_substitution","4x4"], + [("#Given" ,["equalities es_", "solveForVars vs_"]), + ("#Where" , (*accepts missing variables up to diagonal form*) + ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))", + "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))", + "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))", + "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))" + ]), + ("#Find" ,["solution ss___"]) + ], + {rew_ord'="ord_simplify_System", rls' = Erls, calc = [], + srls = append_rls "srls_top_down_4x4" srls [], + prls = append_rls "prls_tri_4x4_lin_sys" prls_triangular + [Calc ("Atools.occurs'_in",eval_occurs_in "")], + crls = Erls, nrls = Erls}, +(*FIXXXXME.WN060916: this script works ONLY for exp 7.79 @@@@@@@@@@@@@@@@@@@@*) +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \ +\ (let e1_ = nth_ 1 es_; \ +\ e2_ = Take (nth_ 2 es_); \ +\ e2_ = ((Substitute [e1_]) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ +\ simplify_System_parenthesized False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ +\ isolate_bdvs False)) @@ \ +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\ +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\ +\ norm_Rational False))) e2_ \ +\ in [e1_, e2_, nth_ 3 es_, nth_ 4 es_])" +)); + +(* show_mets(); + *) + +(* +use"Knowledge/EqSystem.ML"; +use"EqSystem.ML"; +*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/EqSystem.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/EqSystem.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,72 @@ +(* equational systems, minimal -- for use in Biegelinie + author: Walther Neuper + 050826, + (c) due to copyright terms + +remove_thy"EqSystem"; +use_thy"Knowledge/EqSystem"; + +use_thy_only"Knowledge/EqSystem"; + +remove_thy"Typefix"; +use_thy"Knowledge/Isac"; +*) + +EqSystem = Rational + Root + + +consts + + occur'_exactly'_in :: + "[real list, real list, 'a] => bool" ("_ from'_ _ occur'_exactly'_in _") + + (*descriptions in the related problems*) + solveForVars :: real list => toreall + solution :: bool list => toreall + + (*the CAS-command, eg. "solveSystem [x+y=1,y=2] [x,y]"*) + solveSystem :: "[bool list, real list] => bool list" + + (*Script-names*) + SolveSystemScript :: "[bool list, real list, bool list] \ + \=> bool list" + ("((Script SolveSystemScript (_ _ =))// (_))" 9) + +rules +(*stated as axioms, todo: prove as theorems + 'bdv' is a constant handled on the meta-level + specifically as a 'bound variable' *) + + commute_0_equality "(0 = a) = (a = 0)" + + (*WN0510 see simliar rules 'isolate_' 'separate_' (by RL) + [bdv_1,bdv_2,bdv_3,bdv_4] work also for 2 and 3 bdvs, ugly !*) + separate_bdvs_add + "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a |]\ + \ ==> (a + b = c) = (b = c + -1*a)" + separate_bdvs0 + "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in b; Not (b=!=0) |]\ + \ ==> (a = b) = (a + -1*b = 0)" + separate_bdvs_add1 + "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in c |]\ + \ ==> (a = b + c) = (a + -1*c = b)" + separate_bdvs_add2 + "[| Not (some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in a) |]\ + \ ==> (a + b = c) = (b = -1*a + c)" + + + + separate_bdvs_mult + "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a; Not (a=!=0) |]\ + \ ==>(a * b = c) = (b = c / a)" + + (*requires rew_ord for termination, eg. ord_simplify_Integral; + works for lists of any length, interestingly !?!*) + order_system_NxN "[a,b] = [b,a]" + +(* +remove_thy"EqSystem"; +use_thy_only"Knowledge/EqSystem"; +use_thy"Knowledge/EqSystem"; +use"Knowledge/EqSystem.ML"; + *) +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Equation.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Equation.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,85 @@ +(*.(c) by Richard Lang, 2003 .*) +(* defines equation and univariate-equation + created by: rlang + date: 02.09 + changed by: rlang + last change by: rlang + date: 02.11.29 +*) + +(* use_thy_only"Knowledge/Equation"; + use_thy"Knowledge/Equation"; + use"Knowledge/Equation.ML"; + use"Equation.ML"; + *) + +theory' := overwritel (!theory', [("Equation.thy",Equation.thy)]); + +val univariate_equation_prls = + append_rls "univariate_equation_prls" e_rls + [Calc ("Tools.matches",eval_matches "")]; +ruleset' := +overwritelthy thy (!ruleset', + [("univariate_equation_prls", + prep_rls univariate_equation_prls)]); + + +store_pbt + (prep_pbt Equation.thy "pbl_equ" [] e_pblID + (["equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + append_rls "equation_prls" e_rls + [Calc ("Tools.matches",eval_matches "")], + SOME "solve (e_::bool, v_)", + [])); + +store_pbt + (prep_pbt Equation.thy "pbl_equ_univ" [] e_pblID + (["univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + univariate_equation_prls,SOME "solve (e_::bool, v_)",[])); + + +(*.function for handling the cas-input "solve (x+1=2, x)": + make a model which is already in ptree-internal format.*) +(* val (h,argl) = strip_comb (str2term "solve (x+1=2, x)"); + val (h,argl) = strip_comb ((term_of o the o (parse thy)) + "solveTest (x+1=2, x)"); + *) +fun argl2dtss [Const ("Pair", _) $ eq $ bdv] = + [((term_of o the o (parse thy)) "equality", [eq]), + ((term_of o the o (parse thy)) "solveFor", [bdv]), + ((term_of o the o (parse thy)) "solutions", + [(term_of o the o (parse thy)) "L"]) + ] + | argl2dtss _ = raise error "Equation.ML: wrong argument for argl2dtss"; + +castab := +overwritel (!castab, + [((term_of o the o (parse thy)) "solveTest", + (("Test.thy", ["univariate","equation","test"], ["no_met"]), + argl2dtss)), + ((term_of o the o (parse thy)) "solve", + (("Isac.thy", ["univariate","equation"], ["no_met"]), + argl2dtss)) + ]); + + + +store_met + (prep_met Equation.thy "met_equ" [] e_metID + (["Equation"], + [], + {rew_ord'="tless_true", rls'=Erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"empty_script" +)); + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Equation.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Equation.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,29 @@ +(* equations and functions; functions NOT as lambda-terms + author: Walther Neuper 2005, 2006 + (c) due to copyright terms + +remove_thy"Equation"; +use_thy"Knowledge/Equation"; +use_thy_only"Knowledge/Equation"; + +remove_thy"Equation"; +use_thy"Knowledge/Isac"; +*) + +Equation = Atools + + +consts + + (*descriptions in the related problems TODOshift here from Descriptions.thy*) + substitution :: bool => una + + (*the CAS-commands*) + solve :: "[bool * 'a] => bool list" (* solve (x+1=2, x) *) + solveTest :: "[bool * 'a] => bool list" (* for test collection *) + + (*Script-names*) + Function2Equality :: "[bool, bool, bool] \ + \=> bool" + ("((Script Function2Equality (_ _ =))// (_))" 9) + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/InsSort.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/InsSort.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,77 @@ +(* 6.8.02 change to Isabelle2002 caused error -- thy excluded ! + +Proving equations for primrec function(s) "InsSort.foldr" ... +GC #1.17.30.54.345.21479: (10 ms) +*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list" +*** imposes additional sort constraints on the declared type of the constant +*** The error(s) above occurred in definition "InsSort.ins.ins_list_def" +*) + +(* tools for insertion sort + use"Knowledge/InsSort.ML"; +*) + +(** interface isabelle -- isac **) + +theory' := (!theory') @ [("InsSort.thy",InsSort.thy)]; + +(** rule set **) + +val ins_sort = prep_rls( + Rls{preconds = [], rew_ord = ("tless_true",tless_true), + rules = [Thm ("foldr_base",(*num_str*) foldr_base), + Thm ("foldr_rec",foldr_rec), + Thm ("ins_base",ins_base), + Thm ("ins_rec",ins_rec), + Thm ("sort_def",sort_def), + + Calc ("op <",eval_equ "#less_"), + Thm ("if_True", if_True), + Thm ("if_False", if_False) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); + +(** problem type **) + +store_pbt + (prep_pbt InsSort.thy + (["functional"]:pblID, + [("#Given" ,["unsorted u_"]), + ("#Find" ,["sorted s_"]) + ], + [])); + +store_pbt + (prep_pbt InsSort.thy + (["inssort","functional"]:pblID, + [("#Given" ,["unsorted u_"]), + ("#Find" ,["sorted s_"]) + ], + [])); + +(** method, + todo: implementation needs extra object-level lists **) + +store_met + (prep_met Diff.thy + (["InsSort"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls = Atools_rls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); +store_met + (prep_met InsSort.thy (*test-version for [#1,#3,#2] only: see *.sml*) + (["InsSort""sort"]:metID, + [("#Given" ,["unsorted u_"]), + ("#Find" ,["sorted s_"]) + ], + {rew_ord'="tless_true",rls'=eval_rls,calc = [], srls = e_rls, prls=e_rls, + crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)}, + "Script Sort (u_::'a list) = (Rewrite_Set ins_sort False) u_" + )); + +ruleset' := overwritelthy thy (!ruleset', + [(*("ins_sort",ins_sort) overwrites a Isa fun!!*) + ]:(string * rls) list); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/InsSort.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/InsSort.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,395 @@ + + +(*-------------------------from InsSort.thy 8.3.01----------------------*) +(*List.thy: + foldl :: [['b,'a] => 'b, 'b, 'a list] => 'b +primrec + foldl_Nil "foldl f a [] = a" + foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs" + +above in sml: +fun foldr f [] a = a + | foldr f (x::xs) a = foldr f xs (f a x); +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); +fun sort xs = foldr ins xs []; +*) +(*-------------------------from InsSort.thy 8.3.01----------------------*) + + +(*-------------------------from InsSort.ML 8.3.01----------------------*) + +theory' := (!theory') @ [("InsSort.thy",InsSort.thy)]; + +val ins_sort = + Rls{preconds = [], rew_ord = ("tless_true",tless_true), + rules = [Thm ("foldr_base",(*num_str*) foldr_base), + Thm ("foldr_rec",foldr_rec), + Thm ("ins_base",ins_base), + Thm ("ins_rec",ins_rec), + Thm ("sort_def",sort_def), + + Calc ("op <",eval_equ "#less_"), + Thm ("if_True", if_True), + Thm ("if_False", if_False) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + + + + +(* +> get_pbt ["Script.thy","squareroot","univariate","equation"]; +> get_met ("Script.thy","max_on_interval_by_calculus"); +*) +pbltypes:= (!pbltypes) @ +[ + prep_pbt InsSort.thy + (["InsSort.thy","inssort"]:pblID, + [("#Given" ,"unsorted u_"), + ("#Find" ,"sorted s_") + ]) +]; + +methods:= (!methods) @ +[ +(*, -------17.6.00, + (("InsSort.thy","inssort"):metID, + {ppc = prep_met + [("#Given" ,"unsorted u_"), + ("#Find" ,"sorted s_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=Script (((inst_abs (assoc_thm "InsSort.thy")) + o term_of o the o (parse thy)) (*for [#1,#3,#2] only*) + "Script Ins_sort (u_::'a list) = \ + \ (let u_ = Rewrite sort_def False u_; \ + \ u_ = Rewrite foldr_rec False u_; \ + \ u_ = Rewrite ins_base False u_; \ + \ u_ = Rewrite foldr_rec False u_; \ + \ u_ = Rewrite ins_rec False u_; \ + \ u_ = Calculate le u_; \ + \ u_ = Rewrite if_True False u_; \ + \ u_ = Rewrite ins_base False u_; \ + \ u_ = Rewrite foldr_rec False u_; \ + \ u_ = Rewrite ins_rec False u_; \ + \ u_ = Calculate le u_; \ + \ u_ = Rewrite if_True False u_; \ + \ u_ = Rewrite ins_rec False u_; \ + \ u_ = Calculate le u_; \ + \ u_ = Rewrite if_False False u_; \ + \ u_ = Rewrite foldr_base False u_ \ + \ in u_)") + } : met), + + (("InsSort.thy","sort"):metID, + {ppc = prep_met + [("#Given" ,"unsorted u_"), + ("#Find" ,"sorted s_") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=Script ((inst_abs o term_of o the o (parse thy)) + "Script Sort (u_::'a list) = \ + \ Rewrite_Set ins_sort False u_") + } : met) +------- *) +(*, + + (("",""):metID, + {ppc = prep_met + [("#Given" ,""), + ("#Find" ,""), + ("#Relate","") + ], + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[], + scr=EmptyScr} : met), +*) +]; +(*-------------------------from InsSort.ML 8.3.01----------------------*) + + +(*------------------------- nipkow ----------------------*) +consts + sort :: 'a list => 'a list + ins :: ['a,'a list] => 'a list +(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a +*) +rules + ins_base "ins e [] = [e]" + ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))" + +rules + sort_def "sort ls = (foldl ins ls [])" +end + + +(** swp: ..L **) +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) +fun foldL f [] e = e + | foldL f (l::ls) e = f(l,foldL f ls e); + +(* fn : int * int list -> int list *) +fun insL (e,[]) = [e] + | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls); + +fun sortL ls = foldL insL ls []; + +sortL [2,3,1]; (* [1,2,3] *) + + +(** swp, curried: ..LC **) +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) +fun foldLC f [] e = e + | foldLC f (x::xs) e = f x (foldLC f xs e); + +(* fn : int * int list -> int list *) +fun insLC e [] = [e] + | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls); + +fun sortLC ls = foldLC insLC ls []; + +sortLC [2,3,1]; (* [1,2,3] *) + + +(** sml110: ..l **) +(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *) +foldl; +(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!! +fun foldl f e [] = e + | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0 + +foldl op+ (0,[100,11,1]); +val it = 0 : int ... GEHT NICHT !!! *) + +fun insl (e,[]) = [e] + | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls); + +fun sortl ls = foldl insl [] ls; + +sortl [2,3,1]; (* [1,2,3] *) + + +(** sml110, curried: ..lC **) +(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *) +fun foldlC f e [] = e + | foldlC f e (l::ls) = f e (foldlC f e ls); + +(* fn : int -> int list -> int list *) +fun inslC e [] = [e] + | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls); + +fun sortlC ls = foldlC inslC [] ls; + +sortlC [2,3,1]; + +(*--- 15.6.00 ---*) + + +fun Foldl f a [] = a + | Foldl f a (x::xs) = Foldl f (f a x) xs; +(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*) + +fun add a b = a+b:int; + +Foldl add 0 [1,2,3]; + +fun ins0 a [] = [a] + | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs); +(*val ins = fn : int -> int list -> int list*) + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); +(*val ins = fn : int -> int list -> int list*) + +ins 3 [1,2,4]; + +fun sort xs = Foldl ins0 xs []; +(*operator domain: int -> int list -> int + operand: int -> int list -> int list + in expression: + Foldl ins + *) +fun sort xs = Foldl ins xs []; + + + +(*--- 17.6.00 ---*) + + +fun foldr f [] a = a + | foldr f (x::xs) a = foldr f xs (f a x); +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) + +fun add a b = a+b:int; + +fold add [1,2,3] 0; + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); +(*val ins = fn : int list -> int -> int list*) + +ins [1,2,4] 3; + +fun sort xs = foldr ins xs []; + +sort [3,1,4,2]; + + + +(*--- 17.6.00 II ---*) + +fun foldl f a [] = a + | foldl f a (x::xs) = foldl f (f a x) xs; + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); + +fun sort xs = foldl ins xs []; + +sort [3,1,4,2]; +(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*) + +(*------------------------- nipkow ----------------------*) +consts + sort :: 'a list => 'a list + ins :: ['a,'a list] => 'a list +(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a +*) +rules + ins_base "ins e [] = [e]" + ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))" + +rules + sort_def "sort ls = (foldl ins ls [])" +end + + +(** swp: ..L **) +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) +fun foldL f [] e = e + | foldL f (l::ls) e = f(l,foldL f ls e); + +(* fn : int * int list -> int list *) +fun insL (e,[]) = [e] + | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls); + +fun sortL ls = foldL insL ls []; + +sortL [2,3,1]; (* [1,2,3] *) + + +(** swp, curried: ..LC **) +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *) +fun foldLC f [] e = e + | foldLC f (x::xs) e = f x (foldLC f xs e); + +(* fn : int * int list -> int list *) +fun insLC e [] = [e] + | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls); + +fun sortLC ls = foldLC insLC ls []; + +sortLC [2,3,1]; (* [1,2,3] *) + + +(** sml110: ..l **) +(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *) +foldl; +(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!! +fun foldl f e [] = e + | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0 + +foldl op+ (0,[100,11,1]); +val it = 0 : int ... GEHT NICHT !!! *) + +fun insl (e,[]) = [e] + | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls); + +fun sortl ls = foldl insl [] ls; + +sortl [2,3,1]; (* [1,2,3] *) + + +(** sml110, curried: ..lC **) +(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *) +fun foldlC f e [] = e + | foldlC f e (l::ls) = f e (foldlC f e ls); + +(* fn : int -> int list -> int list *) +fun inslC e [] = [e] + | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls); + +fun sortlC ls = foldlC inslC [] ls; + +sortlC [2,3,1]; + +(*--- 15.6.00 ---*) + + +fun Foldl f a [] = a + | Foldl f a (x::xs) = Foldl f (f a x) xs; +(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*) + +fun add a b = a+b:int; + +Foldl add 0 [1,2,3]; + +fun ins0 a [] = [a] + | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs); +(*val ins = fn : int -> int list -> int list*) + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); +(*val ins = fn : int -> int list -> int list*) + +ins 3 [1,2,4]; + +fun sort xs = Foldl ins0 xs []; +(*operator domain: int -> int list -> int + operand: int -> int list -> int list + in expression: + Foldl ins + *) +fun sort xs = Foldl ins xs []; + + + +(*--- 17.6.00 ---*) + + +fun foldr f [] a = a + | foldr f (x::xs) a = foldr f xs (f a x); +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*) + +fun add a b = a+b:int; + +fold add [1,2,3] 0; + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); +(*val ins = fn : int list -> int -> int list*) + +ins [1,2,4] 3; + +fun sort xs = foldr ins xs []; + +sort [3,1,4,2]; + + + +(*--- 17.6.00 II ---*) + +fun foldl f a [] = a + | foldl f a (x::xs) = foldl f (f a x) xs; + +fun ins [] a = [a] + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs); + +fun sort xs = foldl ins xs []; + +sort [3,1,4,2]; +(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*) +(*------------------------- nipkow ----------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/InsSort.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/InsSort.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,63 @@ +(* 6.8.02 change to Isabelle2002 caused error -- thy excluded ! + +Proving equations for primrec function(s) "InsSort.foldr" ... +GC #1.17.30.54.345.21479: (10 ms) +*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list" +*** imposes additional sort constraints on the declared type of the constant +*** The error(s) above occurred in definition "InsSort.ins.ins_list_def (@@@)" +*) + +(* insertion sort, would need lists different from script-lists WN.11.00 +WN.7.5.03: -"- started with someList :: 'a list => unl, fun dest_list +WN.8.5.03: error (@@@) remained with outcommenting foldr ?!? + + use_thy_only"Knowledge/InsSort"; + +*) + +InsSort = Script + + +consts + +(*foldr :: [['a,'b] => 'a, 'b list, 'a] => 'a +WN.8.5.03: already defined in Isabelle2002 (instantiated by Typefix): + "[[real, real] => real, real list, real] => real") : term + + val t = str2term "foldr"; +val t = + Const + ("List.foldr", + "[[RealDef.real, RealDef.real] => RealDef.real, RealDef.real List.list, + RealDef.real] => RealDef.real") : term + *) + ins :: ['a list,'a] => 'a list + sort :: 'a list => 'a list + +(*descriptions, script-id*) + unsorted :: 'a list => unl + sorted :: 'a list => unl + +(*subproblem and script-name*) + Ins'_sort :: "['a list, \ + \ 'a list] => 'a list" + ("((Script Ins'_sort (_ =))// \ + \ (_))" 9) + Sort :: "['a list, \ + \ 'a list] => 'a list" + ("((Script Sort (_ =))// \ + \ (_))" 9) + +(*primrec + foldr_base "foldr f [] a = a" + foldr_rec "foldr f (x#xs) a = foldr f xs (f a x)" +*) + +rules + +(*primrec .. outcommented analoguous to ListC.thy*) + ins_base "ins [] a = [a]" + ins_rec "ins (x#xs) a = (if x < a then x#(ins xs a) else a#(x#xs))" + + sort_def "sort ls = foldr ins ls []" + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Integrate.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Integrate.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,357 @@ +(* tools for integration over the reals + author: Walther Neuper 050905, 08:51 + (c) due to copyright terms + +use"Knowledge/Integrate.ML"; +use"Integrate.ML"; + +remove_thy"Integrate"; +use_thy"Knowledge/Isac"; +*) + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("Integrate.thy",Integrate.thy)]); + +(** eval functions **) + +val c = Free ("c", HOLogic.realT); +(*.create a new unique variable 'c..' in a term; for use by Calc in a rls; + an alternative to do this would be '(Try (Calculate new_c_) (new_c es__))' + in the script; this will be possible if currying doesnt take the value + from a variable, but the value '(new_c es__)' itself.*) +fun new_c term = + let fun selc var = + case (explode o id_of) var of + "c"::[] => true + | "c"::"_"::is => (case (int_of_str o implode) is of + SOME _ => true + | NONE => false) + | _ => false; + fun get_coeff c = case (explode o id_of) c of + "c"::"_"::is => (the o int_of_str o implode) is + | _ => 0; + val cs = filter selc (vars term); + in + case cs of + [] => c + | [c] => Free ("c_2", HOLogic.realT) + | cs => + let val max_coeff = maxl (map get_coeff cs) + in Free ("c_"^string_of_int (max_coeff + 1), HOLogic.realT) end + end; + +(*WN080222 +(*("new_c", ("Integrate.new'_c", eval_new_c "#new_c_"))*) +fun eval_new_c _ _ (p as (Const ("Integrate.new'_c",_) $ t)) _ = + SOME ((term2str p) ^ " = " ^ term2str (new_c p), + Trueprop $ (mk_equality (p, new_c p))) + | eval_new_c _ _ _ _ = NONE; +*) + +(*WN080222:*) +(*("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "#add_new_c_")) + add a new c to a term or a fun-equation; + this is _not in_ the term, because only applied to _whole_ term*) +fun eval_add_new_c (_:string) "Integrate.add'_new'_c" p (_:theory) = + let val p' = case p of + Const ("op =", T) $ lh $ rh => + Const ("op =", T) $ lh $ mk_add rh (new_c rh) + | p => mk_add p (new_c p) + in SOME ((term2str p) ^ " = " ^ term2str p', + Trueprop $ (mk_equality (p, p'))) + end + | eval_add_new_c _ _ _ _ = NONE; + + +(*("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_x_"))*) +fun eval_is_f_x _ _(p as (Const ("Integrate.is'_f'_x", _) + $ arg)) _ = + if is_f_x arg + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_f_x _ _ _ _ = NONE; + +calclist':= overwritel (!calclist', + [(*("new_c", ("Integrate.new'_c", eval_new_c "new_c_")),*) + ("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_")), + ("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_idextifier_")) + ]); + + +(** rulesets **) + +(*.rulesets for integration.*) +val integration_rules = + Rls {id="integration_rules", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Rls {id="conditions_in_integration_rules", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Erls, + srls = Erls, calc = [], + rules = [(*for rewriting conditions in Thm's*) + Calc ("Atools.occurs'_in", + eval_occurs_in "#occurs_in_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",not_false) + ], + scr = EmptyScr}, + srls = Erls, calc = [], + rules = [ + Thm ("integral_const",num_str integral_const), + Thm ("integral_var",num_str integral_var), + Thm ("integral_add",num_str integral_add), + Thm ("integral_mult",num_str integral_mult), + Thm ("integral_pow",num_str integral_pow), + Calc ("op +", eval_binop "#add_")(*for n+1*) + ], + scr = EmptyScr}; +val add_new_c = + Seq {id="add_new_c", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Rls {id="conditions_in_add_new_c", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Erls, + srls = Erls, calc = [], + rules = [Calc ("Tools.matches", eval_matches""), + Calc ("Integrate.is'_f'_x", + eval_is_f_x "is_f_x_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false) + ], + scr = EmptyScr}, + srls = Erls, calc = [], + rules = [ (*Thm ("call_for_new_c", num_str call_for_new_c),*) + Cal1 ("Integrate.add'_new'_c", eval_add_new_c "new_c_") + ], + scr = EmptyScr}; + +(*.rulesets for simplifying Integrals.*) + +(*.for simplify_Integral adapted from 'norm_Rational_rls'.*) +val norm_Rational_rls_noadd_fractions = +Rls {id = "norm_Rational_rls_noadd_fractions", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [(*Rls_ common_nominator_p_rls,!!!*) + Rls_ (*rat_mult_div_pow original corrected WN051028*) + (Rls {id = "rat_mult_div_pow", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = (*FIXME.WN051028 e_rls,*) + append_rls "e_rls-is_polyexp" e_rls + [Calc ("Poly.is'_polyexp", + eval_is_polyexp "")], + srls = Erls, calc = [], + rules = [Thm ("rat_mult",num_str rat_mult), + (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) + Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r), + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) + + Thm ("real_divide_divide1_mg", real_divide_divide1_mg), + (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*) + Thm ("real_divide_divide1_eq", real_divide_divide1_eq), + (*"?x / (?y / ?z) = ?x * ?z / ?y"*) + Thm ("real_divide_divide2_eq", real_divide_divide2_eq), + (*"?x / ?y / ?z = ?x / (?y * ?z)"*) + Calc ("HOL.divide" ,eval_cancel "#divide_"), + + Thm ("rat_power", num_str rat_power) + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }), + Rls_ make_rat_poly_with_parentheses, + Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*) + Rls_ rat_reduce_1 + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls; + +(*.for simplify_Integral adapted from 'norm_Rational'.*) +val norm_Rational_noadd_fractions = + Seq {id = "norm_Rational_noadd_fractions", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [Rls_ discard_minus_, + Rls_ rat_mult_poly,(* removes double fractions like a/b/c *) + Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*) + Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*) + Rls_ norm_Rational_rls_noadd_fractions,(* the main rls (#) *) + Rls_ discard_parentheses_ (* mult only *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls; + +(*.simplify terms before and after Integration such that + ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO + common denominator as done by norm_Rational or make_ratpoly_in. + This is a copy from 'make_ratpoly_in' with respective reduction of rules and + *1* expand the term, ie. distribute * and / over + +.*) +val separate_bdv2 = + append_rls "separate_bdv2" + collect_bdv + [Thm ("separate_bdv", num_str separate_bdv), + (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) + Thm ("separate_bdv_n", num_str separate_bdv_n), + Thm ("separate_1_bdv", num_str separate_1_bdv), + (*"?bdv / ?b = (1 / ?b) * ?bdv"*) + Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*, + (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) + *****Thm ("real_add_divide_distrib", + *****num_str real_add_divide_distrib) + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)----------*) + ]; +val simplify_Integral = + Seq {id = "simplify_Integral", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [], (*asm_thm = [],*) + rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib), + (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*) + Thm ("real_add_divide_distrib",num_str real_add_divide_distrib), + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*) + (*^^^^^ *1* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*) + Rls_ norm_Rational_noadd_fractions, + Rls_ order_add_mult_in, + Rls_ discard_parentheses, + (*Rls_ collect_bdv, from make_polynomial_in*) + Rls_ separate_bdv2, + Calc ("HOL.divide" ,eval_cancel "#divide_") + ], + scr = EmptyScr}:rls; + + +(*simplify terms before and after Integration such that + ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO + common denominator as done by norm_Rational or make_ratpoly_in. + This is a copy from 'make_polynomial_in' with insertions from + 'make_ratpoly_in' +THIS IS KEPT FOR COMPARISON ............................................ +* val simplify_Integral = prep_rls( +* Seq {id = "", preconds = []:term list, +* rew_ord = ("dummy_ord", dummy_ord), +* erls = Atools_erls, srls = Erls, +* calc = [], (*asm_thm = [],*) +* rules = [Rls_ expand_poly, +* Rls_ order_add_mult_in, +* Rls_ simplify_power, +* Rls_ collect_numerals, +* Rls_ reduce_012, +* Thm ("realpow_oneI",num_str realpow_oneI), +* Rls_ discard_parentheses, +* Rls_ collect_bdv, +* (*below inserted from 'make_ratpoly_in'*) +* Rls_ (append_rls "separate_bdv" +* collect_bdv +* [Thm ("separate_bdv", num_str separate_bdv), +* (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) +* Thm ("separate_bdv_n", num_str separate_bdv_n), +* Thm ("separate_1_bdv", num_str separate_1_bdv), +* (*"?bdv / ?b = (1 / ?b) * ?bdv"*) +* Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*, +* (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) +* Thm ("real_add_divide_distrib", +* num_str real_add_divide_distrib) +* (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)*) +* ]), +* Calc ("HOL.divide" ,eval_cancel "#divide_") +* ], +* scr = EmptyScr +* }:rls); +.......................................................................*) + +val integration = + Seq {id="integration", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Rls {id="conditions_in_integration", + preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Erls, + srls = Erls, calc = [], + rules = [], + scr = EmptyScr}, + srls = Erls, calc = [], + rules = [ Rls_ integration_rules, + Rls_ add_new_c, + Rls_ simplify_Integral + ], + scr = EmptyScr}; +ruleset' := +overwritelthy thy (!ruleset', + [("integration_rules", prep_rls integration_rules), + ("add_new_c", prep_rls add_new_c), + ("simplify_Integral", prep_rls simplify_Integral), + ("integration", prep_rls integration), + ("separate_bdv2", separate_bdv2), + ("norm_Rational_noadd_fractions", norm_Rational_noadd_fractions), + ("norm_Rational_rls_noadd_fractions", + norm_Rational_rls_noadd_fractions) + ]); + +(** problems **) + +store_pbt + (prep_pbt Integrate.thy "pbl_fun_integ" [] e_pblID + (["integrate","function"], + [("#Given" ,["functionTerm f_", "integrateBy v_"]), + ("#Find" ,["antiDerivative F_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "Integrate (f_, v_)", + [["diff","integration"]])); + +(*here "named" is used differently from Differentiation"*) +store_pbt + (prep_pbt Integrate.thy "pbl_fun_integ_nam" [] e_pblID + (["named","integrate","function"], + [("#Given" ,["functionTerm f_", "integrateBy v_"]), + ("#Find" ,["antiDerivativeName F_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "Integrate (f_, v_)", + [["diff","integration","named"]])); + +(** methods **) + +store_met + (prep_met Integrate.thy "met_diffint" [] e_metID + (["diff","integration"], + [("#Given" ,["functionTerm f_", "integrateBy v_"]), + ("#Find" ,["antiDerivative F_"]) + ], + {rew_ord'="tless_true", rls'=Atools_erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"Script IntegrationScript (f_::real) (v_::real) = \ +\ (let t_ = Take (Integral f_ D v_) \ +\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) (t_::real))" +)); + +store_met + (prep_met Integrate.thy "met_diffint_named" [] e_metID + (["diff","integration","named"], + [("#Given" ,["functionTerm f_", "integrateBy v_"]), + ("#Find" ,["antiDerivativeName F_"]) + ], + {rew_ord'="tless_true", rls'=Atools_erls, calc = [], + srls = e_rls, + prls=e_rls, + crls = Atools_erls, nrls = e_rls}, +"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \ +\ (let t_ = Take (F_ v_ = Integral f_ D v_) \ +\ in ((Try (Rewrite_Set_Inst [(bdv,v_)] simplify_Integral False)) @@\ +\ (Rewrite_Set_Inst [(bdv,v_)] integration False)) t_)" +(* +"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \ +\ (let t_ = Take (F_ v_ = Integral f_ D v_) \ +\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) t_)" +*) + )); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Integrate.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Integrate.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,54 @@ +(* integration over the reals + author: Walther Neuper + 050814, 08:51 + (c) due to copyright terms + +remove_thy"Integrate"; +use_thy"Knowledge/Integrate"; +use_thy_only"Knowledge/Integrate"; + +remove_thy"Typefix"; +use_thy"Knowledge/Isac"; +*) + +Integrate = Diff + + +consts + + Integral :: "[real, real]=> real" ("Integral _ D _" 91) +(*new'_c :: "real => real" ("new'_c _" 66)*) + is'_f'_x :: "real => bool" ("_ is'_f'_x" 10) + + (*descriptions in the related problems*) + integrateBy :: real => una + antiDerivative :: real => una + antiDerivativeName :: (real => real) => una + + (*the CAS-command, eg. "Integrate (2*x^^^3, x)"*) + Integrate :: "[real * real] => real" + + (*Script-names*) + IntegrationScript :: "[real,real, real] => real" + ("((Script IntegrationScript (_ _ =))// (_))" 9) + NamedIntegrationScript :: "[real,real, real=>real, bool] => bool" + ("((Script NamedIntegrationScript (_ _ _=))// (_))" 9) + +rules +(*stated as axioms, todo: prove as theorems + 'bdv' is a constant handled on the meta-level + specifically as a 'bound variable' *) + + integral_const "Not (bdv occurs_in u) ==> Integral u D bdv = u * bdv" + integral_var "Integral bdv D bdv = bdv ^^^ 2 / 2" + + integral_add "Integral (u + v) D bdv = \ + \(Integral u D bdv) + (Integral v D bdv)" + integral_mult "[| Not (bdv occurs_in u); bdv occurs_in v |] ==> \ + \Integral (u * v) D bdv = u * (Integral v D bdv)" +(*WN080222: this goes into sub-terms, too ... + call_for_new_c "[| Not (matches (u + new_c v) a); Not (a is_f_x) |] ==> \ + \a = a + new_c a" +*) + integral_pow "Integral bdv ^^^ n D bdv = bdv ^^^ (n+1) / (n + 1)" + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Isac.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Isac.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,37 @@ +(* collect all knowledge defined in theories so far + author: Walther Neuper 0003 + (c) isac-team + +use"Knowledge/Isac.ML"; +use"Isac.ML"; + *) + + +theory' := overwritel (!theory', [("Isac.thy",Isac.thy)]); + + +(**.set up a list for getting guh + theID for a thm (defined in isabelle).**) + +(*.get all theorems used by isac and defined in isabelle.*) +local + val isacrlsthms = ((gen_distinct eq_thmI) o (map rep_thm_G') o flat o + (map (thms_of_rls o #2 o #2))) (!ruleset'); + val isacthms = (flat o (map (PureThy.all_thms_of o #2))) (!theory'); +in + val rlsthmsNOTisac = gen_diff eq_thmI (isacrlsthms, isacthms); +end; + +(*.set up the list using 'val first_isac_thy' (see ListC.ML).*) +isab_thm_thy := make_isab rlsthmsNOTisac + ((#ancestors o rep_theory) first_isac_thy); + + +(*.create the hierarchy of theory elements from IsacKnowledge + including thms from Isabelle used in rls; + elements store_*d in any *.ML are not overwritten.*) + +thehier := the_hier (!thehier) (collect_thydata ()); +writeln("----------------------------------\n\ + \*** insert: not found ... IS OK : \n\ + \comes from fill_parents \n\ + \----------------------------------\n"); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Isac.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Isac.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,21 @@ +(* theory collecting all knowledge defined so far + WN.11.00 + *) + +Isac = PolyMinus + PolyEq + Vect + DiffApp + Biegelinie + AlgEin + + (*InsSort +*) Test + + +end + +(* dependencies alternative to those defined by R.Lang during his thesis: + + Poly Root + |\__________ | + | \ | + | Rational | + | | | + PolyEq RatEq RootEq + \ / \ / + \ / \ / + RatPolyEq RatRootEq etc. +*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/LinEq.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/LinEq.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,171 @@ +(*. (c) by Richard Lang, 2003 .*) +(* collecting all knowledge for LinearEquations + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.11.04 +*) + +(* remove_thy"LinEq"; + use_thy"Knowledge/Isac"; + + use_thy"Knowledge/LinEq"; + + use"ROOT.ML"; + cd"knowledge"; +*) + +"******* LinEq.ML begin *******"; + +(*-------------------- theory -------------------------------------------------*) +theory' := overwritel (!theory', [("LinEq.thy",LinEq.thy)]); + +(*-------------- rules -------------------------------------------------------*) +val LinEq_prls = (*3.10.02:just the following order due to subterm evaluation*) + append_rls "LinEq_prls" e_rls + [Calc ("op =",eval_equal "#equal_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Tools.lhs" ,eval_lhs ""), + Calc ("Tools.rhs" ,eval_rhs ""), + Calc ("Poly.has'_degree'_in",eval_has_degree_in ""), + Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""), + Calc ("Atools.occurs'_in",eval_occurs_in ""), + Calc ("Atools.ident",eval_ident "#ident_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false), + Thm ("or_true",num_str or_true), + Thm ("or_false",num_str or_false) + ]; +(* ----- erls ----- *) +val LinEq_crls = + append_rls "LinEq_crls" poly_crls + [Thm ("real_assoc_1",num_str real_assoc_1) + (* + Don't use + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + *) + ]; + +(* ----- crls ----- *) +val LinEq_erls = + append_rls "LinEq_erls" Poly_erls + [Thm ("real_assoc_1",num_str real_assoc_1) + (* + Don't use + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + *) + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("LinEq_erls",LinEq_erls)(*FIXXXME:del with rls.rls'*) + ]); + +val LinPoly_simplify = prep_rls( + Rls {id = "LinPoly_simplify", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = LinEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [ + Thm ("real_assoc_1",num_str real_assoc_1), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_"), + (* Dont use + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + *) + Calc ("Atools.pow" ,eval_binop "#power_") + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("LinPoly_simplify",LinPoly_simplify)]); + +(*isolate the bound variable in an linear equation; 'bdv' is a meta-constant*) +val LinEq_simplify = prep_rls( +Rls {id = "LinEq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = LinEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("lin_isolate_div","")],*) + rules = [ + Thm("lin_isolate_add1",num_str lin_isolate_add1), + (* a+bx=0 -> bx=-a *) + Thm("lin_isolate_add2",num_str lin_isolate_add2), + (* a+ x=0 -> x=-a *) + Thm("lin_isolate_div",num_str lin_isolate_div) + (* bx=c -> x=c/b *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("LinEq_simplify",LinEq_simplify)]); + +(*----------------------------- problem types --------------------------------*) +(* +show_ptyps(); +(get_pbt ["linear","univariate","equation"]); +*) +(* ---------linear----------- *) +store_pbt + (prep_pbt LinEq.thy "pbl_equ_univ_lin" [] e_pblID + (["linear","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["False", (*WN0509 just detected: this pbl can never be used?!?*) + "Not( (lhs e_) is_polyrat_in v_)", + "Not( (rhs e_) is_polyrat_in v_)", + "((lhs e_) has_degree_in v_)=1", + "((rhs e_) has_degree_in v_)=1"]), + ("#Find" ,["solutions v_i_"]) + ], + LinEq_prls, SOME "solve (e_::bool, v_)", + [["LinEq","solve_lineq_equation"]])); + +(*-------------- methods-------------------------------------------------------*) +store_met + (prep_met LinEq.thy "met_eqlin" [] e_metID + (["LinEq"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=LinEq_crls, nrls=norm_Poly + (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); + +(* ansprechen mit ["LinEq","solve_univar_equation"] *) +store_met +(prep_met LinEq.thy "met_eq_lin" [] e_metID + (["LinEq","solve_lineq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["Not( (lhs e_) is_polyrat_in v_)", + "( (lhs e_) has_degree_in v_)=1"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=LinEq_erls, + srls=e_rls, + prls=LinEq_prls, + calc=[], + crls=LinEq_crls, nrls=norm_Poly(*, + asm_rls=[], + asm_thm=[("lin_isolate_div","")]*)}, + "Script Solve_lineq_equation (e_::bool) (v_::real) = \ + \(let e_ =((Try (Rewrite all_left False)) @@ \ + \ (Try (Repeat (Rewrite makex1_x False))) @@ \ + \ (Try (Rewrite_Set expand_binoms False)) @@ \ + \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ make_ratpoly_in False))) @@ \ + \ (Try (Repeat (Rewrite_Set LinPoly_simplify False)))) e_;\ + \ e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ LinEq_simplify True)) @@ \ + \ (Repeat(Try (Rewrite_Set LinPoly_simplify False)))) e_ \ + \ in ((Or_to_List e_)::bool list))" + )); +"******* LinEq.ML end *******"; +get_met ["LinEq","solve_lineq_equation"]; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/LinEq.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/LinEq.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,50 @@ +(*. (c) by Richard Lang, 2003 .*) +(* theory collecting all knowledge for LinearEquations + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.10.20 +*) + +(* + use"knowledge/LinEq.ML"; + use"LinEq.ML"; + + use"ROOT.ML"; + cd"knowledge"; + +*) + +LinEq = Poly + Equation + + +(*-------------------- consts------------------------------------------------*) +consts + Solve'_lineq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_lineq'_equation (_ _ =))// \ + \ (_))" 9) + +(*-------------------- rules -------------------------------------------------*) +rules +(*-- normalize --*) + (*WN0509 compare PolyEq.all_left "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"*) + all_left + "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)" + makex1_x + "a^^^1 = a" + real_assoc_1 + "a+(b+c) = a+b+c" + real_assoc_2 + "a*(b*c) = a*b*c" + +(*-- solve --*) + lin_isolate_add1 + "(a + b*bdv = 0) = (b*bdv = (-1)*a)" + lin_isolate_add2 + "(a + bdv = 0) = ( bdv = (-1)*a)" + lin_isolate_div + "[|Not(b=0)|] ==> (b*bdv = c) = (bdv = c / b)" +end + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/LogExp.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/LogExp.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,39 @@ +(* all outcommented in order to demonstrate authoring: + WN071203 +*) + +(** interface isabelle -- isac **) +theory' := overwritel (!theory', [("LogExp.thy",LogExp.thy)]); + +(*--------------------------------------------------*) + +(** problems **) +store_pbt + (prep_pbt LogExp.thy "pbl_test_equ_univ_log" [] e_pblID + (["logarithmic","univariate","equation"], + [("#Given",["equality e_","solveFor v_"]), + ("#Where",["matches ((?a log ?v_) = ?b) e_"]), + ("#Find" ,["solutions v_i_"]), + ("#With" ,["||(lhs (Subst (v_i_,v_) e_) - \ + \ (rhs (Subst (v_i_,v_) e_) || < eps)"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["Equation","solve_log"]])); + +(** methods **) +store_met + (prep_met LogExp.thy "met_equ_log" [] e_metID + (["Equation","solve_log"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches ((?a log ?v_) = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls, + calc=[],crls=PolyEq_crls, nrls=norm_Rational}, + "Script Solve_log (e_::bool) (v_::real) = \ + \(let e_ = ((Rewrite equality_power False) @@ \ + \ (Rewrite exp_invers_log False) @@ \ + \ (Rewrite_Set norm_Poly False)) e_ \ + \ in [e_])" + )); +(*--------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/LogExp.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/LogExp.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,30 @@ +(* all outcommented in order to demonstrate authoring: + WN071203 +remove_thy"LogExp"; +use_thy_only"Knowledge/LogExp"; +use_thy_only"Knowledge/Isac"; +*) +LogExp = PolyEq + + +consts + + ln :: "real => real" + exp :: "real => real" ("E'_ ^^^ _" 80) + +(*--------------------------------------------------*) + alog :: "[real, real] => real" ("_ log _" 90) + + (*Script-names*) + Solve'_log :: "[bool,real, bool list] \ + \=> bool list" + ("((Script Solve'_log (_ _=))//(_))" 9) + +rules + + equality_pow "0 < a ==> (l = r) = (a^^^l = a^^^r)" + (* this is what students ^^^^^^^... are told to do *) + equality_power "((a log b) = c) = (a^^^(a log b) = a^^^c)" + exp_invers_log "a^^^(a log b) = b" +(*---------------------------------------------------*) + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Poly.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Poly.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1495 @@ +(*.eval_funs, rulesets, problems and methods concerning polynamials + authors: Matthias Goldgruber 2003 + (c) due to copyright terms + + use"../Knowledge/Poly.ML"; + use"Knowledge/Poly.ML"; + use"Poly.ML"; + + remove_thy"Poly"; + use_thy"Knowledge/Isac"; +****************************************************************.*) + +(*.**************************************************************** + remark on 'polynomials' + WN020919 + there are 5 kinds of expanded normalforms: +[1] 'complete polynomial' (Komplettes Polynom), univariate + a_0 + a_1.x^1 +...+ a_n.x^n not (a_n = 0) + not (a_n = 0), some a_i may be zero (DON'T disappear), + variables in monomials lexicographically ordered and complete, + x written as 1*x^1, ... +[2] 'polynomial' (Polynom), univariate and multivariate + a_0 + a_1.x +...+ a_n.x^n not (a_n = 0) + 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 + not (a_n = 0), some a_i may be zero (ie. monomials disappear), + exponents and coefficients equal 1 are not (WN060904.TODO in cancel_p_)shown, + and variables in monomials are lexicographically ordered + examples: [1]: "1 + (-10) * x ^^^ 1 + 25 * x ^^^ 2" + [1]: "11 + 0 * x ^^^ 1 + 1 * x ^^^ 2" + [2]: "x + (-50) * x ^^^ 3" + [2]: "(-1) * x * y ^^^ 2 + 7 * x ^^^ 3" + +[3] 'expanded_term' (Ausmultiplizierter Term): + pull out unary minus to binary minus, + as frequently exercised in schools; other conditions for [2] hold however + examples: "a ^^^ 2 - 2 * a * b + b ^^^ 2" + "4 * x ^^^ 2 - 9 * y ^^^ 2" +[4] 'polynomial_in' (Polynom in): + polynomial in 1 variable with arbitrary coefficients + examples: "2 * x + (-50) * x ^^^ 3" (poly in x) + "(u + v) + (2 * u ^^^ 2) * a + (-u) * a ^^^ 2 (poly in a) +[5] 'expanded_in' (Ausmultiplizierter Termin in): + analoguous to [3] with binary minus like [3] + examples: "2 * x - 50 * x ^^^ 3" (expanded in x) + "(u + v) + (2 * u ^^^ 2) * a - u * a ^^^ 2 (expanded in a) +*****************************************************************.*) + +"******** Poly.ML begin ******************************************"; +theory' := overwritel (!theory', [("Poly.thy",Poly.thy)]); + + +(* is_polyrat_in becomes true, if no bdv is in the denominator of a fraction*) +fun is_polyrat_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun finddivide (_ $ _ $ _ $ _) v = raise error("is_polyrat_in:") + (* at the moment there is no term like this, but ....*) + | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = not(coeff_in b v) + | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) orelse (finddivide t2 v) + | finddivide (_ $ t1) v = (finddivide t1 v) + | finddivide _ _ = false; + in + finddivide t v + end; + +fun eval_is_polyrat_in _ _ (p as (Const ("Poly.is'_polyrat'_in",_) $ t $ v)) _ = + if is_polyrat_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_polyrat_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + + +local + (*.a 'c is coefficient of v' if v does NOT occur in c.*) + fun coeff_in c v = not (member op = (vars c) v); + (* + val v = (term_of o the o (parse thy)) "x"; + val t = (term_of o the o (parse thy)) "1"; + coeff_in t v; + (*val it = true : bool*) + val t = (term_of o the o (parse thy)) "a*b+c"; + coeff_in t v; + (*val it = true : bool*) + val t = (term_of o the o (parse thy)) "a*x+c"; + coeff_in t v; + (*val it = false : bool*) + *) + (*. a 'monomial t in variable v' is a term t with + either (1) v NOT existent in t, or (2) v contained in t, + if (1) then degree 0 + if (2) then v is a factor on the very right, ev. with exponent.*) + fun factor_right_deg (*case 2*) + (t as Const ("op *",_) $ t1 $ + (Const ("Atools.pow",_) $ vv $ Free (d,_))) v = + if ((vv = v) andalso (coeff_in t1 v)) then SOME (int_of_str' d) else NONE + | factor_right_deg + (t as Const ("Atools.pow",_) $ vv $ Free (d,_)) v = + if (vv = v) then SOME (int_of_str' d) else NONE + | factor_right_deg (t as Const ("op *",_) $ t1 $ vv) v = + if ((vv = v) andalso (coeff_in t1 v))then SOME 1 else NONE + | factor_right_deg vv v = + if (vv = v) then SOME 1 else NONE; + fun mono_deg_in m v = + if coeff_in m v then (*case 1*) SOME 0 + else factor_right_deg m v; + (* + val v = (term_of o the o (parse thy)) "x"; + val t = (term_of o the o (parse thy)) "(a*b+c)*x^^^7"; + mono_deg_in t v; + (*val it = SOME 7*) + val t = (term_of o the o (parse thy)) "x^^^7"; + mono_deg_in t v; + (*val it = SOME 7*) + val t = (term_of o the o (parse thy)) "(a*b+c)*x"; + mono_deg_in t v; + (*val it = SOME 1*) + val t = (term_of o the o (parse thy)) "(a*b+x)*x"; + mono_deg_in t v; + (*val it = NONE*) + val t = (term_of o the o (parse thy)) "x"; + mono_deg_in t v; + (*val it = SOME 1*) + val t = (term_of o the o (parse thy)) "(a*b+c)"; + mono_deg_in t v; + (*val it = SOME 0*) + val t = (term_of o the o (parse thy)) "ab - (a*b)*x"; + mono_deg_in t v; + (*val it = NONE*) + *) + fun expand_deg_in t v = + let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) = + (case mono_deg_in t2 v of (* $ is left associative*) + SOME d' => edi d' d' t1 + | NONE => NONE) + | edi ~1 ~1 (Const ("op -",_) $ t1 $ t2) = + (case mono_deg_in t2 v of + SOME d' => edi d' d' t1 + | NONE => NONE) + | edi d dmax (Const ("op -",_) $ t1 $ t2) = + (case mono_deg_in t2 v of + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE + | NONE => NONE) + | edi d dmax (Const ("op +",_) $ t1 $ t2) = + (case mono_deg_in t2 v of + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE + | NONE => NONE) + | edi ~1 ~1 t = + (case mono_deg_in t v of + d as SOME _ => d + | NONE => NONE) + | edi d dmax t = (*basecase last*) + (case mono_deg_in t v of + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE + | NONE => NONE) + in edi ~1 ~1 t end; + (* + val v = (term_of o the o (parse thy)) "x"; + val t = (term_of o the o (parse thy)) "a+b"; + expand_deg_in t v; + (*val it = SOME 0*) + val t = (term_of o the o (parse thy)) "(a+b)*x"; + expand_deg_in t v; + (*SOME 1*) + val t = (term_of o the o (parse thy)) "a*b - (a+b)*x"; + expand_deg_in t v; + (*SOME 1*) + val t = (term_of o the o (parse thy)) "a*b + (a-b)*x"; + expand_deg_in t v; + (*SOME 1*) + val t = (term_of o the o (parse thy)) "a*b + (a+b)*x + x^^^2"; + expand_deg_in t v; + *) + fun poly_deg_in t v = + let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) = + (case mono_deg_in t2 v of (* $ is left associative*) + SOME d' => edi d' d' t1 + | NONE => NONE) + | edi d dmax (Const ("op +",_) $ t1 $ t2) = + (case mono_deg_in t2 v of + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*) + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE + | NONE => NONE) + | edi ~1 ~1 t = + (case mono_deg_in t v of + d as SOME _ => d + | NONE => NONE) + | edi d dmax t = (*basecase last*) + (case mono_deg_in t v of + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE + | NONE => NONE) + in edi ~1 ~1 t end; +in + +fun is_expanded_in t v = + case expand_deg_in t v of SOME _ => true | NONE => false; +fun is_poly_in t v = + case poly_deg_in t v of SOME _ => true | NONE => false; +fun has_degree_in t v = + case expand_deg_in t v of SOME d => d | NONE => ~1; +end; +(* + val v = (term_of o the o (parse thy)) "x"; + val t = (term_of o the o (parse thy)) "a*b - (a+b)*x + x^^^2"; + has_degree_in t v; + (*val it = 2*) + val t = (term_of o the o (parse thy)) "-8 - 2*x + x^^^2"; + has_degree_in t v; + (*val it = 2*) + val t = (term_of o the o (parse thy)) "6 + 13*x + 6*x^^^2"; + has_degree_in t v; + (*val it = 2*) +*) + +(*("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in ""))*) +fun eval_is_expanded_in _ _ + (p as (Const ("Poly.is'_expanded'_in",_) $ t $ v)) _ = + if is_expanded_in t v + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_expanded_in _ _ _ _ = NONE; +(* + val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) is_expanded_in x"; + val SOME (id, t') = eval_is_expanded_in 0 0 t 0; + (*val id = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*) + term2str t'; + (*val it = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*) +*) +(*("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in ""))*) +fun eval_is_poly_in _ _ + (p as (Const ("Poly.is'_poly'_in",_) $ t $ v)) _ = + if is_poly_in t v + then SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_poly_in _ _ _ _ = NONE; +(* + val t = (term_of o the o (parse thy)) "(8 + 2*x + x^^^2) is_poly_in x"; + val SOME (id, t') = eval_is_poly_in 0 0 t 0; + (*val id = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*) + term2str t'; + (*val it = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*) +*) + +(*("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in ""))*) +fun eval_has_degree_in _ _ + (p as (Const ("Poly.has'_degree'_in",_) $ t $ v)) _ = + let val d = has_degree_in t v + val d' = term_of_num HOLogic.realT d + in SOME ((term2str p) ^ " = " ^ (string_of_int d), + Trueprop $ (mk_equality (p, d'))) + end + | eval_has_degree_in _ _ _ _ = NONE; +(* +> val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) has_degree_in x"; +> val SOME (id, t') = eval_has_degree_in 0 0 t 0; +val id = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string +> term2str t'; +val it = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string +*) + +(*..*) +val calculate_Poly = + append_rls "calculate_PolyFIXXXME.not.impl." e_rls + []; + +(*.for evaluation of conditions in rewrite rules.*) +val Poly_erls = + append_rls "Poly_erls" Atools_erls + [ Calc ("op =",eval_equal "#equal_"), + Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("Atools.pow" ,eval_binop "#power_") + ]; + +val poly_crls = + append_rls "poly_crls" Atools_crls + [ Calc ("op =",eval_equal "#equal_"), + Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("Atools.pow" ,eval_binop "#power_") + ]; + + +local (*. for make_polynomial .*) + +open Term; (* for type order = EQUAL | LESS | GREATER *) + +fun pr_ord EQUAL = "EQUAL" + | pr_ord LESS = "LESS" + | pr_ord GREATER = "GREATER"; + +fun dest_hd' (Const (a, T)) = (* ~ term.ML *) + (case a of + "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest string*) + | _ => (((a, 0), T), 0)) + | dest_hd' (Free (a, T)) = (((a, 0), T), 1) + | dest_hd' (Var v) = (v, 2) + | dest_hd' (Bound i) = ((("", i), dummyT), 3) + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); + +fun get_order_pow (t $ (Free(order,_))) = (* RL FIXXXME:geht zufaellig?WN*) + (case int_of_str (order) of + SOME d => d + | NONE => 0) + | get_order_pow _ = 0; + +fun size_of_term' (Const(str,_) $ t) = + if "Atools.pow"= str then 1000 + size_of_term' t else 1+size_of_term' t(*WN*) + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body + | size_of_term' (f$t) = size_of_term' f + size_of_term' t + | size_of_term' _ = 1; + +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) + | term_ord' pr thy (t, u) = + (if pr then + let + val (f, ts) = strip_comb t and (g, us) = strip_comb u; + val _=writeln("t= f@ts= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy))ts))^"]\""); + val _=writeln("u= g@us= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy))us))^"]\""); + val _=writeln("size_of_term(t,u)= ("^ + (string_of_int(size_of_term' t))^", "^ + (string_of_int(size_of_term' u))^")"); + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); + val _=writeln("terms_ord(ts,us) = "^ + ((pr_ord o terms_ord str false)(ts,us))); + val _=writeln("-------"); + in () end + else (); + case int_ord (size_of_term' t, size_of_term' u) of + EQUAL => + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) + | ord => ord) + end + | ord => ord) +and hd_ord (f, g) = (* ~ term.ML *) + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) +and terms_ord str pr (ts, us) = + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); +in + +fun ord_make_polynomial (pr:bool) thy (_:subst) tu = + (term_ord' pr thy(***) tu = LESS ); + +end;(*local*) + + +rew_ord' := overwritel (!rew_ord', +[("termlessI", termlessI), + ("ord_make_polynomial", ord_make_polynomial false thy) + ]); + + +val expand = + Rls{id = "expand", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2) + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + ], scr = EmptyScr}:rls; + +(*----------------- Begin: rulesets for make_polynomial_ ----------------- + 'rlsIDs' redefined by MG as 'rlsIDs_' + ^^^*) + +val discard_minus_ = + Rls{id = "discard_minus_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_diff_minus",num_str real_diff_minus), + (*"a - b = a + -1 * b"*) + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) + (*- ?z = "-1 * ?z"*) + ], scr = EmptyScr}:rls; +val expand_poly_ = + Rls{id = "expand_poly_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_plus_binom_pow4",num_str real_plus_binom_pow4), + (*"(a + b)^^^4 = ... "*) + Thm ("real_plus_binom_pow5",num_str real_plus_binom_pow5), + (*"(a + b)^^^5 = ... "*) + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), + (*"(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *) + + (*WN071229 changed/removed for Schaerding -----vvv*) + (*Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),*) + (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) + Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2), + (*"(a + b)^^^2 = (a + b) * (a + b)"*) + (*Thm ("real_plus_minus_binom1_p_p", + num_str real_plus_minus_binom1_p_p),*) + (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*) + (*Thm ("real_plus_minus_binom2_p_p", + num_str real_plus_minus_binom2_p_p),*) + (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*) + (*WN071229 changed/removed for Schaerding -----^^^*) + + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + + Thm ("realpow_multI", num_str realpow_multI), + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) + Thm ("realpow_pow",num_str realpow_pow) + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) + ], scr = EmptyScr}:rls; + +(*.the expression contains + - * ^ only ? + this is weaker than 'is_polynomial' !.*) +fun is_polyexp (Free _) = true + | is_polyexp (Const ("op +",_) $ Free _ $ Free _) = true + | is_polyexp (Const ("op -",_) $ Free _ $ Free _) = true + | is_polyexp (Const ("op *",_) $ Free _ $ Free _) = true + | is_polyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true + | is_polyexp (Const ("op +",_) $ t1 $ t2) = + ((is_polyexp t1) andalso (is_polyexp t2)) + | is_polyexp (Const ("op -",_) $ t1 $ t2) = + ((is_polyexp t1) andalso (is_polyexp t2)) + | is_polyexp (Const ("op *",_) $ t1 $ t2) = + ((is_polyexp t1) andalso (is_polyexp t2)) + | is_polyexp (Const ("Atools.pow",_) $ t1 $ t2) = + ((is_polyexp t1) andalso (is_polyexp t2)) + | is_polyexp _ = false; + +(*("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp ""))*) +fun eval_is_polyexp (thmid:string) _ + (t as (Const("Poly.is'_polyexp", _) $ arg)) thy = + if is_polyexp arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.true_const))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.false_const))) + | eval_is_polyexp _ _ _ _ = NONE; + +val expand_poly_rat_ = + Rls{id = "expand_poly_rat_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = append_rls "e_rls-is_polyexp" e_rls + [Calc ("Poly.is'_polyexp", eval_is_polyexp "") + ], + srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_plus_binom_pow4_poly",num_str real_plus_binom_pow4_poly), + (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^4 = ... "*) + Thm ("real_plus_binom_pow5_poly",num_str real_plus_binom_pow5_poly), + (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^5 = ... "*) + Thm ("real_plus_binom_pow2_poly",num_str real_plus_binom_pow2_poly), + (*"[| a is_polyexp; b is_polyexp |] ==> + (a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) + Thm ("real_plus_binom_pow3_poly",num_str real_plus_binom_pow3_poly), + (*"[| a is_polyexp; b is_polyexp |] ==> + (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *) + Thm ("real_plus_minus_binom1_p_p",num_str real_plus_minus_binom1_p_p), + (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*) + Thm ("real_plus_minus_binom2_p_p",num_str real_plus_minus_binom2_p_p), + (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*) + + Thm ("real_add_mult_distrib_poly" ,num_str real_add_mult_distrib_poly), + (*"w is_polyexp ==> (z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2_poly",num_str real_add_mult_distrib2_poly), + (*"w is_polyexp ==> w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + + Thm ("realpow_multI_poly", num_str realpow_multI_poly), + (*"[| r is_polyexp; s is_polyexp |] ==> + (r * s) ^^^ n = r ^^^ n * s ^^^ n"*) + Thm ("realpow_pow",num_str realpow_pow) + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) + ], scr = EmptyScr}:rls; + +val simplify_power_ = + Rls{id = "simplify_power_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls, srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [(*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen + a*(a*a) --> a*a^^^2 und nicht a*(a*a) --> a^^^2*a *) + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r * r = r ^^^ 2"*) + Thm ("realpow_twoI_assoc_l",num_str realpow_twoI_assoc_l), + (*"r * (r * s) = r ^^^ 2 * s"*) + + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("realpow_plus_1_assoc_l", num_str realpow_plus_1_assoc_l), + (*"r * (r ^^^ m * s) = r ^^^ (1 + m) * s"*) + (*MG 9.7.03: neues Thm wegen a*(a*(a*b)) --> a^^^2*(a*b) *) + Thm ("realpow_plus_1_assoc_l2", num_str realpow_plus_1_assoc_l2), + (*"r ^^^ m * (r * s) = r ^^^ (1 + m) * s"*) + + Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)), + (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) + Thm ("realpow_addI_assoc_l", num_str realpow_addI_assoc_l), + (*"r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"*) + + (* ist in expand_poly - wird hier aber auch gebraucht, wegen: + "r * r = r ^^^ 2" wenn r=a^^^b*) + Thm ("realpow_pow",num_str realpow_pow) + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) + ], scr = EmptyScr}:rls; + +val calc_add_mult_pow_ = + Rls{id = "calc_add_mult_pow_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls(*erls3.4.03*),srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], scr = EmptyScr}:rls; + +val reduce_012_mult_ = + Rls{id = "reduce_012_mult_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [(* MG: folgende Thm müssen hier stehen bleiben: *) + Thm ("real_mult_1_right",num_str real_mult_1_right), + (*"z * 1 = z"*) (*wegen "a * b * b^^^(-1) + a"*) + Thm ("realpow_zeroI",num_str realpow_zeroI), + (*"r ^^^ 0 = 1"*) (*wegen "a*a^^^(-1)*c + b + c"*) + Thm ("realpow_oneI",num_str realpow_oneI), + (*"r ^^^ 1 = r"*) + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI) + (*"1 ^^^ n = 1"*) + ], scr = EmptyScr}:rls; + +val collect_numerals_ = + Rls{id = "collect_numerals_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")) + ], + rules = [Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r), + (*"[| l is_const; m is_const |] ==> \ + \(k + m * n) + l * n = k + (l + m)*n"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r), + (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*) + + Calc ("op +", eval_binop "#add_"), + + (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen + (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *) + Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r), + (*"(k + z1) + z1 = k + 2 * z1"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)) + (*"z1 + z1 = 2 * z1"*) + + ], scr = EmptyScr}:rls; + +val reduce_012_ = + Rls{id = "reduce_012_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_mult_0_right",num_str real_mult_0_right), + (*"z * 0 = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + Thm ("real_add_zero_right",num_str real_add_zero_right), + (*"z + 0 = z"*) (*wegen a+b-b --> a+(1-1)*b --> a+0 --> a*) + + (*Thm ("realpow_oneI",num_str realpow_oneI)*) + (*"?r ^^^ 1 = ?r"*) + Thm ("real_0_divide",num_str real_0_divide)(*WN060914*) + (*"0 / ?x = 0"*) + ], scr = EmptyScr}:rls; + +(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*) +val discard_parentheses_ = + append_rls "discard_parentheses_" e_rls + [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)) + (*"?z1.1 * (?z2.1 * ?z3.1) = ?z1.1 * ?z2.1 * ?z3.1"*) + (*Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))*) + (*"?z1.1 + (?z2.1 + ?z3.1) = ?z1.1 + ?z2.1 + ?z3.1"*) + ]; + +(*----------------- End: rulesets for make_polynomial_ -----------------*) + +(*MG.0401 ev. for use in rls with ordered rewriting ? +val collect_numerals_left = + Rls{id = "collect_numerals", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls(*erls3.4.03*),srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> + l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> n + (m * n + k) = (1 + m) * n + k"*) + + Calc ("op +", eval_binop "#add_"), + + (*MG am 2.5.03: 2 Theoreme aus reduce_012 hierher verschoben*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc) + (*"z1 + (z1 + k) = 2 * z1 + k"*) + ], scr = EmptyScr}:rls;*) + +val expand_poly = + Rls{id = "expand_poly", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + (*Thm ("real_add_mult_distrib1",num_str real_add_mult_distrib1), + ....... 18.3.03 undefined???*) + + Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2), + (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) + Thm ("real_minus_binom_pow2_p",num_str real_minus_binom_pow2_p), + (*"(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"*) + Thm ("real_plus_minus_binom1_p", + num_str real_plus_minus_binom1_p), + (*"(a + b)*(a - b) = a^^^2 + -1*b^^^2"*) + Thm ("real_plus_minus_binom2_p", + num_str real_plus_minus_binom2_p), + (*"(a - b)*(a + b) = a^^^2 + -1*b^^^2"*) + + Thm ("real_minus_minus",num_str real_minus_minus), + (*"- (- ?z) = ?z"*) + Thm ("real_diff_minus",num_str real_diff_minus), + (*"a - b = a + -1 * b"*) + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) + (*- ?z = "-1 * ?z"*) + + (*Thm ("",num_str ), + Thm ("",num_str ), + Thm ("",num_str ),*) + (*Thm ("real_minus_add_distrib", + num_str real_minus_add_distrib),*) + (*"- (?x + ?y) = - ?x + - ?y"*) + (*Thm ("real_diff_plus",num_str real_diff_plus)*) + (*"a - b = a + -b"*) + ], scr = EmptyScr}:rls; +val simplify_power = + Rls{id = "simplify_power", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls, srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("realpow_multI", num_str realpow_multI), + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("realpow_pow",num_str realpow_pow), + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) + Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)), + (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) + Thm ("realpow_oneI",num_str realpow_oneI), + (*"r ^^^ 1 = r"*) + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI) + (*"1 ^^^ n = 1"*) + ], scr = EmptyScr}:rls; +(*MG.0401: termorders for multivariate polys dropped due to principal problems: + (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*) +val order_add_mult = + Rls{id = "order_add_mult", preconds = [], + rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_mult_commute",num_str real_mult_commute), + (* z * w = w * z *) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) + Thm ("real_mult_assoc",num_str real_mult_assoc), + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) + Thm ("real_add_commute",num_str real_add_commute), + (*z + w = w + z*) + Thm ("real_add_left_commute",num_str real_add_left_commute), + (*x + (y + z) = y + (x + z)*) + Thm ("real_add_assoc",num_str real_add_assoc) + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) + ], scr = EmptyScr}:rls; +(*MG.0401: termorders for multivariate polys dropped due to principal problems: + (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*) +val order_mult = + Rls{id = "order_mult", preconds = [], + rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_mult_commute",num_str real_mult_commute), + (* z * w = w * z *) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) + Thm ("real_mult_assoc",num_str real_mult_assoc) + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) + ], scr = EmptyScr}:rls; +val collect_numerals = + Rls{id = "collect_numerals", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls(*erls3.4.03*),srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> + l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], scr = EmptyScr}:rls; +val reduce_012 = + Rls{id = "reduce_012", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + (*Thm ("real_mult_minus1",num_str real_mult_minus1),14.3.03*) + (*"-1 * z = - z"*) + Thm ("sym_real_mult_minus_eq1", + num_str (real_mult_minus_eq1 RS sym)), + (*- (?x * ?y) = "- ?x * ?y"*) + (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel), + (*"- ?x * - ?y = ?x * ?y"*)---*) + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + Thm ("real_add_minus",num_str real_add_minus), + (*"?z + - ?z = 0"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc) + (*"z1 + (z1 + k) = 2 * z1 + k"*) + ], scr = EmptyScr}:rls; +(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*) +val discard_parentheses = + append_rls "discard_parentheses" e_rls + [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)), + Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))]; + +val scr_make_polynomial = +"Script Expand_binoms t_ =\ +\(Repeat \ +\((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + +\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \ +\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \ +\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \ +\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \ +\ (Try (Repeat (Rewrite real_add_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_)))) \ +\ t_)"; + +(*version used by MG.02/03, overwritten by version AG in 04 below +val make_polynomial = prep_rls( + Seq{id = "make_polynomial", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [],(*asm_thm = [],*) + rules = [Rls_ expand_poly, + Rls_ order_add_mult, + Rls_ simplify_power, (*realpow_eq_oneI, eg. x^1 --> x *) + Rls_ collect_numerals, (*eg. x^(2+ -1) --> x^1 *) + Rls_ reduce_012, + Thm ("realpow_oneI",num_str realpow_oneI),(*in --^*) + Rls_ discard_parentheses + ], + scr = EmptyScr + }:rls); *) + +val scr_expand_binoms = +"Script Expand_binoms t_ =\ +\(Repeat \ +\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \ +\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \ +\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_))) @@ \ + +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_)))) \ +\ t_)"; + +val expand_binoms = + Rls{id = "expand_binoms", preconds = [], rew_ord = ("termlessI",termlessI), + erls = Atools_erls, srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), + (*"(a + b)*(a + b) = ...*) + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) + Thm ("real_minus_binom_times",num_str real_minus_binom_times), + (*"(a - b)*(a - b) = ...*) + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) + (*RL 020915*) + Thm ("real_pp_binom_times",num_str real_pp_binom_times), + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) + Thm ("real_pm_binom_times",num_str real_pm_binom_times), + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) + Thm ("real_mp_binom_times",num_str real_mp_binom_times), + (*(a - b)*(c + d) = a*c + a*d - b*c - b*d*) + Thm ("real_mm_binom_times",num_str real_mm_binom_times), + (*(a - b)*(c - d) = a*c - a*d - b*c + b*d*) + Thm ("realpow_multI",num_str realpow_multI), + (*(a*b)^^^n = a^^^n * b^^^n*) + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), + (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *) + Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3), + (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *) + + + (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) + *) + + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_"), + (* + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) + Thm ("real_mult_assoc",num_str real_mult_assoc), (**) + Thm ("real_add_commute",num_str real_add_commute), (**) + Thm ("real_add_left_commute",num_str real_add_left_commute), (**) + Thm ("real_add_assoc",num_str real_add_assoc), (**) + *) + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*)*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], + scr = Script ((term_of o the o (parse thy)) scr_expand_binoms) + }:rls; + + +"******* Poly.ML end ******* ...RL"; + + +(**. MG.03: make_polynomial_ ... uses SML-fun for ordering .**) + +(*FIXME.0401: make SML-order local to make_polynomial(_) *) +(*FIXME.0401: replace 'make_polynomial'(old) by 'make_polynomial_'(MG) *) +(* Polynom --> List von Monomen *) +fun poly2list (Const ("op +",_) $ t1 $ t2) = + (poly2list t1) @ (poly2list t2) + | poly2list t = [t]; + +(* Monom --> Liste von Variablen *) +fun monom2list (Const ("op *",_) $ t1 $ t2) = + (monom2list t1) @ (monom2list t2) + | monom2list t = [t]; + +(* liefert Variablenname (String) einer Variablen und Basis bei Potenz *) +fun get_basStr (Const ("Atools.pow",_) $ Free (str, _) $ _) = str + | get_basStr (Free (str, _)) = str + | get_basStr t = "|||"; (* gross gewichtet; für Brüch ect. *) +(*| get_basStr t = + raise error("get_basStr: called with t= "^(term2str t));*) + +(* liefert Hochzahl (String) einer Variablen bzw Gewichtstring (zum Sortieren) *) +fun get_potStr (Const ("Atools.pow",_) $ Free _ $ Free (str, _)) = str + | get_potStr (Const ("Atools.pow",_) $ Free _ $ _ ) = "|||" (* gross gewichtet *) + | get_potStr (Free (str, _)) = "---" (* keine Hochzahl --> kleinst gewichtet *) + | get_potStr t = "||||||"; (* gross gewichtet; für Brüch ect. *) +(*| get_potStr t = + raise error("get_potStr: called with t= "^(term2str t));*) + +(* Umgekehrte string_ord *) +val string_ord_rev = rev_order o string_ord; + + (* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen) + innerhalb eines Monomes: + - zuerst lexikographisch nach Variablenname + - wenn gleich: nach steigender Potenz *) +fun var_ord (a,b: term) = prod_ord string_ord string_ord + ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b)); + +(* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen); + verwendet zum Sortieren von Monomen mittels Gesamtgradordnung: + - zuerst lexikographisch nach Variablenname + - wenn gleich: nach sinkender Potenz*) +fun var_ord_revPow (a,b: term) = prod_ord string_ord string_ord_rev + ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b)); + + +(* Ordnet ein Liste von Variablen (und Potenzen) lexikographisch *) +val sort_varList = sort var_ord; + +(* Entfernet aeussersten Operator (Wurzel) aus einem Term und schreibt + Argumente in eine Liste *) +fun args u : term list = + let fun stripc (f$t, ts) = stripc (f, t::ts) + | stripc (t as Free _, ts) = (t::ts) + | stripc (_, ts) = ts + in stripc (u, []) end; + +(* liefert True, falls der Term (Liste von Termen) nur Zahlen + (keine Variablen) enthaelt *) +fun filter_num [] = true + | filter_num [Free x] = if (is_num (Free x)) then true + else false + | filter_num ((Free _)::_) = false + | filter_num ts = + (filter_num o (filter_out is_num) o flat o (map args)) ts; + +(* liefert True, falls der Term nur Zahlen (keine Variablen) enthaelt + dh. er ist ein numerischer Wert und entspricht einem Koeffizienten *) +fun is_nums t = filter_num [t]; + +(* Berechnet den Gesamtgrad eines Monoms *) +local + fun counter (n, []) = n + | counter (n, x :: xs) = + if (is_nums x) then + counter (n, xs) + else + (case x of + (Const ("Atools.pow", _) $ Free (str_b, _) $ Free (str_h, T)) => + if (is_nums (Free (str_h, T))) then + counter (n + (the (int_of_str str_h)), xs) + else counter (n + 1000, xs) (*FIXME.MG?!*) + | (Const ("Atools.pow", _) $ Free (str_b, _) $ _ ) => + counter (n + 1000, xs) (*FIXME.MG?!*) + | (Free (str, _)) => counter (n + 1, xs) + (*| _ => raise error("monom_degree: called with factor: "^(term2str x)))*) + | _ => counter (n + 10000, xs)) (*FIXME.MG?! ... Brüche ect.*) +in + fun monom_degree l = counter (0, l) +end; + +(* wie Ordnung dict_ord (lexicographische Ordnung zweier Listen, mit Vergleich + der Listen-Elemente mit elem_ord) - Elemente die Bedingung cond erfuellen, + werden jedoch dabei ignoriert (uebersprungen) *) +fun dict_cond_ord _ _ ([], []) = EQUAL + | dict_cond_ord _ _ ([], _ :: _) = LESS + | dict_cond_ord _ _ (_ :: _, []) = GREATER + | dict_cond_ord elem_ord cond (x :: xs, y :: ys) = + (case (cond x, cond y) of + (false, false) => (case elem_ord (x, y) of + EQUAL => dict_cond_ord elem_ord cond (xs, ys) + | ord => ord) + | (false, true) => dict_cond_ord elem_ord cond (x :: xs, ys) + | (true, false) => dict_cond_ord elem_ord cond (xs, y :: ys) + | (true, true) => dict_cond_ord elem_ord cond (xs, ys) ); + +(* Gesamtgradordnung zum Vergleich von Monomen (Liste von Variablen/Potenzen): + zuerst nach Gesamtgrad, bei gleichem Gesamtgrad lexikographisch ordnen - + dabei werden Koeffizienten ignoriert (2*3*a^^^2*4*b gilt wie a^^^2*b) *) +fun degree_ord (xs, ys) = + prod_ord int_ord (dict_cond_ord var_ord_revPow is_nums) + ((monom_degree xs, xs), (monom_degree ys, ys)); + +fun hd_str str = substring (str, 0, 1); +fun tl_str str = substring (str, 1, (size str) - 1); + +(* liefert nummerischen Koeffizienten eines Monoms oder NONE *) +fun get_koeff_of_mon [] = raise error("get_koeff_of_mon: called with l = []") + | get_koeff_of_mon (l as x::xs) = if is_nums x then SOME x + else NONE; + +(* wandelt Koeffizient in (zum sortieren geeigneten) String um *) +fun koeff2ordStr (SOME x) = (case x of + (Free (str, T)) => + if (hd_str str) = "-" then (tl_str str)^"0" (* 3 < -3 *) + else str + | _ => "aaa") (* "num.Ausdruck" --> gross *) + | koeff2ordStr NONE = "---"; (* "kein Koeff" --> kleinste *) + +(* Order zum Vergleich von Koeffizienten (strings): + "kein Koeff" < "0" < "1" < "-1" < "2" < "-2" < ... < "num.Ausdruck" *) +fun compare_koeff_ord (xs, ys) = + string_ord ((koeff2ordStr o get_koeff_of_mon) xs, + (koeff2ordStr o get_koeff_of_mon) ys); + +(* Gesamtgradordnung degree_ord + Ordnen nach Koeffizienten falls EQUAL *) +fun koeff_degree_ord (xs, ys) = + prod_ord degree_ord compare_koeff_ord ((xs, xs), (ys, ys)); + +(* Ordnet ein Liste von Monomen (Monom = Liste von Variablen) mittels + Gesamtgradordnung *) +val sort_monList = sort koeff_degree_ord; + +(* Alternativ zu degree_ord koennte auch die viel einfachere und + kuerzere Ordnung simple_ord verwendet werden - ist aber nicht + fuer unsere Zwecke geeignet! + +fun simple_ord (al,bl: term list) = dict_ord string_ord + (map get_basStr al, map get_basStr bl); + +val sort_monList = sort simple_ord; *) + +(* aus 2 Variablen wird eine Summe bzw ein Produkt erzeugt + (mit gewuenschtem Typen T) *) +fun plus T = Const ("op +", [T,T] ---> T); +fun mult T = Const ("op *", [T,T] ---> T); +fun binop op_ t1 t2 = op_ $ t1 $ t2; +fun create_prod T (a,b) = binop (mult T) a b; +fun create_sum T (a,b) = binop (plus T) a b; + +(* löscht letztes Element einer Liste *) +fun drop_last l = take ((length l)-1,l); + +(* Liste von Variablen --> Monom *) +fun create_monom T vl = foldr (create_prod T) (drop_last vl, last_elem vl); +(* Bemerkung: + foldr bewirkt rechtslastige Klammerung des Monoms - ist notwendig, damit zwei + gleiche Monome zusammengefasst werden können (collect_numerals)! + zB: 2*(x*(y*z)) + 3*(x*(y*z)) --> (2+3)*(x*(y*z))*) + +(* Liste von Monomen --> Polynom *) +fun create_polynom T ml = foldl (create_sum T) (hd ml, tl ml); +(* Bemerkung: + foldl bewirkt linkslastige Klammerung des Polynoms (der Summanten) - + bessere Darstellung, da keine Klammern sichtbar! + (und discard_parentheses in make_polynomial hat weniger zu tun) *) + +(* sorts the variables (faktors) of an expanded polynomial lexicographical *) +fun sort_variables t = + let + val ll = map monom2list (poly2list t); + val lls = map sort_varList ll; + val T = type_of t; + val ls = map (create_monom T) lls; + in create_polynom T ls end; + +(* sorts the monoms of an expanded and variable-sorted polynomial + by total_degree *) +fun sort_monoms t = + let + val ll = map monom2list (poly2list t); + val lls = sort_monList ll; + val T = type_of t; + val ls = map (create_monom T) lls; + in create_polynom T ls end; + +(* auch Klammerung muss übereinstimmen; + sort_variables klammert Produkte rechtslastig*) +fun is_multUnordered t = ((is_polyexp t) andalso not (t = sort_variables t)); + +fun eval_is_multUnordered (thmid:string) _ + (t as (Const("Poly.is'_multUnordered", _) $ arg)) thy = + if is_multUnordered arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.true_const))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.false_const))) + | eval_is_multUnordered _ _ _ _ = NONE; + + +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; +fun init_state (_:term) = e_rrlsstate; +fun locate_rule (_:rule list list) (_:term) (_:rule) = + ([]:(rule * (term * term list)) list); +fun next_rule (_:rule list list) (_:term) = (NONE:rule option); +fun normal_form t = SOME (sort_variables t,[]:term list); + +val order_mult_ = + Rrls {id = "order_mult_", + prepat = + [([(term_of o the o (parse thy)) "p is_multUnordered"], + (term_of o the o (parse thy)) "?p" )], + rew_ord = ("dummy_ord", dummy_ord), + erls = append_rls "e_rls-is_multUnordered" e_rls(*MG: poly_erls*) + [Calc ("Poly.is'_multUnordered", eval_is_multUnordered "") + ], + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + (*asm_thm=[],*) + scr=Rfuns {init_state = init_state, + normal_form = normal_form, + locate_rule = locate_rule, + next_rule = next_rule, + attach_form = attach_form}}; + +val order_mult_rls_ = + Rls{id = "order_mult_rls_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Rls_ order_mult_ + ], scr = EmptyScr}:rls; + +fun is_addUnordered t = ((is_polyexp t) andalso not (t = sort_monoms t)); + +(*WN.18.6.03 *) +(*("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))*) +fun eval_is_addUnordered (thmid:string) _ + (t as (Const("Poly.is'_addUnordered", _) $ arg)) thy = + if is_addUnordered arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.true_const))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.false_const))) + | eval_is_addUnordered _ _ _ _ = NONE; + +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; +fun init_state (_:term) = e_rrlsstate; +fun locate_rule (_:rule list list) (_:term) (_:rule) = + ([]:(rule * (term * term list)) list); +fun next_rule (_:rule list list) (_:term) = (NONE:rule option); +fun normal_form t = SOME (sort_monoms t,[]:term list); + +val order_add_ = + Rrls {id = "order_add_", + prepat = (*WN.18.6.03 Preconditions und Pattern, + die beide passen muessen, damit das Rrls angewandt wird*) + [([(term_of o the o (parse thy)) "p is_addUnordered"], + (term_of o the o (parse thy)) "?p" + (*WN.18.6.03 also KEIN pattern, dieses erzeugt nur das Environment + fuer die Evaluation der Precondition "p is_addUnordered"*))], + rew_ord = ("dummy_ord", dummy_ord), + erls = append_rls "e_rls-is_addUnordered" e_rls(*MG: poly_erls*) + [Calc ("Poly.is'_addUnordered", eval_is_addUnordered "") + (*WN.18.6.03 definiert in Poly.thy, + evaluiert prepat*)], + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + (*asm_thm=[],*) + scr=Rfuns {init_state = init_state, + normal_form = normal_form, + locate_rule = locate_rule, + next_rule = next_rule, + attach_form = attach_form}}; + +val order_add_rls_ = + Rls{id = "order_add_rls_", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Rls_ order_add_ + ], scr = EmptyScr}:rls; + +(*. see MG-DA.p.52ff .*) +val make_polynomial(*MG.03, overwrites version from above, + previously 'make_polynomial_'*) = + Seq {id = "make_polynomial", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls,calc = [], + rules = [Rls_ discard_minus_, + Rls_ expand_poly_, + Calc ("op *", eval_binop "#mult_"), + Rls_ order_mult_rls_, + Rls_ simplify_power_, + Rls_ calc_add_mult_pow_, + Rls_ reduce_012_mult_, + Rls_ order_add_rls_, + Rls_ collect_numerals_, + Rls_ reduce_012_, + Rls_ discard_parentheses_ + ], + scr = EmptyScr + }:rls; +val norm_Poly(*=make_polynomial*) = + Seq {id = "norm_Poly", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, calc = [], + rules = [Rls_ discard_minus_, + Rls_ expand_poly_, + Calc ("op *", eval_binop "#mult_"), + Rls_ order_mult_rls_, + Rls_ simplify_power_, + Rls_ calc_add_mult_pow_, + Rls_ reduce_012_mult_, + Rls_ order_add_rls_, + Rls_ collect_numerals_, + Rls_ reduce_012_, + Rls_ discard_parentheses_ + ], + scr = EmptyScr + }:rls; + +(* MG:03 Like make_polynomial_ but without Rls_ discard_parentheses_ + and expand_poly_rat_ instead of expand_poly_, see MG-DA.p.56ff*) +(* MG necessary for termination of norm_Rational(*_mg*) in Rational.ML*) +val make_rat_poly_with_parentheses = + Seq{id = "make_rat_poly_with_parentheses", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, calc = [], + rules = [Rls_ discard_minus_, + Rls_ expand_poly_rat_,(*ignors rationals*) + Calc ("op *", eval_binop "#mult_"), + Rls_ order_mult_rls_, + Rls_ simplify_power_, + Rls_ calc_add_mult_pow_, + Rls_ reduce_012_mult_, + Rls_ order_add_rls_, + Rls_ collect_numerals_, + Rls_ reduce_012_ + (*Rls_ discard_parentheses_ *) + ], + scr = EmptyScr + }:rls; + +(*.a minimal ruleset for reverse rewriting of factions [2]; + compare expand_binoms.*) +val rev_rew_p = +Seq{id = "reverse_rewriting", preconds = [], rew_ord = ("termlessI",termlessI), + erls = Atools_erls, srls = Erls, + calc = [(*("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_"))*) + ], + rules = [Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), + (*"(a + b)*(a + b) = a ^ 2 + 2 * a * b + b ^ 2*) + Thm ("real_plus_binom_times1" ,num_str real_plus_binom_times1), + (*"(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"*) + Thm ("real_plus_binom_times2" ,num_str real_plus_binom_times2), + (*"(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"*) + + Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*) + + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + + Thm ("real_mult_assoc", num_str real_mult_assoc), + (*"?z1.1 * ?z2.1 * ?z3. =1 ?z1.1 * (?z2.1 * ?z3.1)"*) + Rls_ order_mult_rls_, + (*Rls_ order_add_rls_,*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_"), + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> + l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Thm ("realpow_multI", num_str realpow_multI), + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_"), + + Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0),(*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left)(*0 + z = z*) + + (*Rls_ order_add_rls_*) + ], + + scr = EmptyScr}:rls; + +ruleset' := +overwritelthy thy (!ruleset', + [("norm_Poly", prep_rls norm_Poly), + ("Poly_erls",Poly_erls)(*FIXXXME:del with rls.rls'*), + ("expand", prep_rls expand), + ("expand_poly", prep_rls expand_poly), + ("simplify_power", prep_rls simplify_power), + ("order_add_mult", prep_rls order_add_mult), + ("collect_numerals", prep_rls collect_numerals), + ("collect_numerals_", prep_rls collect_numerals_), + ("reduce_012", prep_rls reduce_012), + ("discard_parentheses", prep_rls discard_parentheses), + ("make_polynomial", prep_rls make_polynomial), + ("expand_binoms", prep_rls expand_binoms), + ("rev_rew_p", prep_rls rev_rew_p), + ("discard_minus_", prep_rls discard_minus_), + ("expand_poly_", prep_rls expand_poly_), + ("expand_poly_rat_", prep_rls expand_poly_rat_), + ("simplify_power_", prep_rls simplify_power_), + ("calc_add_mult_pow_", prep_rls calc_add_mult_pow_), + ("reduce_012_mult_", prep_rls reduce_012_mult_), + ("reduce_012_", prep_rls reduce_012_), + ("discard_parentheses_",prep_rls discard_parentheses_), + ("order_mult_rls_", prep_rls order_mult_rls_), + ("order_add_rls_", prep_rls order_add_rls_), + ("make_rat_poly_with_parentheses", + prep_rls make_rat_poly_with_parentheses) + (*("", prep_rls ), + ("", prep_rls ), + ("", prep_rls ) + *) + ]); + +calclist':= overwritel (!calclist', + [("is_polyrat_in", ("Poly.is'_polyrat'_in", + eval_is_polyrat_in "#eval_is_polyrat_in")), + ("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in "")), + ("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in "")), + ("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in "")), + ("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp "")), + ("is_multUnordered", ("Poly.is'_multUnordered", eval_is_multUnordered"")), + ("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered "")) + ]); + + +(** problems **) + +store_pbt + (prep_pbt Poly.thy "pbl_simp_poly" [] e_pblID + (["polynomial","simplification"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*) + Calc ("Poly.is'_polyexp", eval_is_polyexp "")], + SOME "Simplify t_", + [["simplification","for_polynomials"]])); + + +(** methods **) + +store_met + (prep_met Poly.thy "met_simp_poly" [] e_metID + (["simplification","for_polynomials"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", + rls' = e_rls, + calc = [], + srls = e_rls, + prls = append_rls "simplification_for_polynomials_prls" e_rls + [(*for preds in where_*) + Calc ("Poly.is'_polyexp",eval_is_polyexp"")], + crls = e_rls, nrls = norm_Poly}, + "Script SimplifyScript (t_::real) = \ + \ ((Rewrite_Set norm_Poly False) t_)" + )); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Poly.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Poly.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,147 @@ +(* WN.020812: theorems in the Reals, + necessary for special rule sets, in addition to Isabelle2002. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! THIS IS THE _least_ NUMBER OF ADDITIONAL THEOREMS !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + xxxI contain ^^^ instead of ^ in the respective theorem xxx in 2002 + changed by: Richard Lang 020912 +*) + +(* + use_thy"Knowledge/Poly"; + use_thy"Poly"; + use_thy_only"Knowledge/Poly"; + + remove_thy"Poly"; + use_thy"Knowledge/Isac"; + + + use"ROOT.ML"; + cd"IsacKnowledge"; + *) + +Poly = Simplify + + +(*-------------------- consts-----------------------------------------------*) +consts + + is'_expanded'_in :: "[real, real] => bool" ("_ is'_expanded'_in _") + is'_poly'_in :: "[real, real] => bool" ("_ is'_poly'_in _") (*RL DA *) + has'_degree'_in :: "[real, real] => real" ("_ has'_degree'_in _")(*RL DA *) + is'_polyrat'_in :: "[real, real] => bool" ("_ is'_polyrat'_in _")(*RL030626*) + + is'_multUnordered :: "real => bool" ("_ is'_multUnordered") + is'_addUnordered :: "real => bool" ("_ is'_addUnordered") (*WN030618*) + is'_polyexp :: "real => bool" ("_ is'_polyexp") + + Expand'_binoms + :: "['y, \ + \ 'y] => 'y" + ("((Script Expand'_binoms (_ =))// \ + \ (_))" 9) + +(*-------------------- rules------------------------------------------------*) +rules (*.not contained in Isabelle2002, + stated as axioms, TODO: prove as theorems; + theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*) + + realpow_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)" + realpow_addI "r ^^^ (n + m) = r ^^^ n * r ^^^ m" + realpow_addI_assoc_l "r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s" + realpow_addI_assoc_r "s * r ^^^ n * r ^^^ m = s * r ^^^ (n + m)" + + realpow_oneI "r ^^^ 1 = r" + realpow_zeroI "r ^^^ 0 = 1" + realpow_eq_oneI "1 ^^^ n = 1" + realpow_multI "(r * s) ^^^ n = r ^^^ n * s ^^^ n" + realpow_multI_poly "[| r is_polyexp; s is_polyexp |] ==> \ + \(r * s) ^^^ n = r ^^^ n * s ^^^ n" + realpow_minus_oneI "-1 ^^^ (2 * n) = 1" + + realpow_twoI "r ^^^ 2 = r * r" + realpow_twoI_assoc_l "r * (r * s) = r ^^^ 2 * s" + realpow_twoI_assoc_r "s * r * r = s * r ^^^ 2" + realpow_two_atom "r is_atom ==> r * r = r ^^^ 2" + realpow_plus_1 "r * r ^^^ n = r ^^^ (n + 1)" + realpow_plus_1_assoc_l "r * (r ^^^ m * s) = r ^^^ (1 + m) * s" + realpow_plus_1_assoc_l2 "r ^^^ m * (r * s) = r ^^^ (1 + m) * s" + realpow_plus_1_assoc_r "s * r * r ^^^ m = s * r ^^^ (1 + m)" + realpow_plus_1_atom "r is_atom ==> r * r ^^^ n = r ^^^ (1 + n)" + realpow_def_atom "[| Not (r is_atom); 1 < n |] \ + \ ==> r ^^^ n = r * r ^^^ (n + -1)" + realpow_addI_atom "r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)" + + + realpow_minus_even "n is_even ==> (- r) ^^^ n = r ^^^ n" + realpow_minus_odd "Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n" + + +(* RL 020914 *) + real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d" + real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d" + real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d" + real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d" + real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" + real_plus_binom_pow3_poly "[| a is_polyexp; b is_polyexp |] ==> \ + \(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" + real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3" + real_minus_binom_pow3_p "(a + -1 * b)^^^3 = a^^^3 + -3*a^^^2*b + 3*a*b^^^2 + -1*b^^^3" +(* real_plus_binom_pow "[| n is_const; 3 < n |] ==> \ + \(a + b)^^^n = (a + b) * (a + b)^^^(n - 1)" *) + real_plus_binom_pow4 "(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)" + real_plus_binom_pow4_poly "[| a is_polyexp; b is_polyexp |] ==> \ + \(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)" + 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)" + + real_plus_binom_pow5_poly "[| a is_polyexp; b is_polyexp |] ==> \ + \(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)" + + real_diff_plus "a - b = a + -b" (*17.3.03: do_NOT_use*) + real_diff_minus "a - b = a + -1 * b" + real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2" + real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2" + (*WN071229 changed for Schaerding -----vvv*) + (*real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*) + real_plus_binom_pow2 "(a + b)^^^2 = (a + b) * (a + b)" + (*WN071229 changed for Schaerding -----^^^*) + real_plus_binom_pow2_poly "[| a is_polyexp; b is_polyexp |] ==> \ + \(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2" + real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2" + real_minus_binom_pow2_p "(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2" + real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2" + real_plus_minus_binom1_p "(a + b)*(a - b) = a^^^2 + -1*b^^^2" + real_plus_minus_binom1_p_p "(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2" + real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2" + real_plus_minus_binom2_p "(a - b)*(a + b) = a^^^2 + -1*b^^^2" + real_plus_minus_binom2_p_p "(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2" + real_plus_binom_times1 "(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2" + real_plus_binom_times2 "(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2" + + real_num_collect "[| l is_const; m is_const |] ==> \ + \l * n + m * n = (l + m) * n" +(* FIXME.MG.0401: replace 'real_num_collect_assoc' + by 'real_num_collect_assoc_l' ... are equal, introduced by MG ! *) + real_num_collect_assoc "[| l is_const; m is_const |] ==> \ + \l * n + (m * n + k) = (l + m) * n + k" + real_num_collect_assoc_l "[| l is_const; m is_const |] ==> \ + \l * n + (m * n + k) = (l + m) + * n + k" + real_num_collect_assoc_r "[| l is_const; m is_const |] ==> \ + \(k + m * n) + l * n = k + (l + m) * n" + real_one_collect "m is_const ==> n + m * n = (1 + m) * n" +(* FIXME.MG.0401: replace 'real_one_collect_assoc' + by 'real_one_collect_assoc_l' ... are equal, introduced by MG ! *) + real_one_collect_assoc "m is_const ==> n + (m * n + k) = (1 + m)* n + k" + + real_one_collect_assoc_l "m is_const ==> n + (m * n + k) = (1 + m) * n + k" + real_one_collect_assoc_r "m is_const ==>(k + n) + m * n = k + (1 + m) * n" + +(* FIXME.MG.0401: replace 'real_mult_2_assoc' + by 'real_mult_2_assoc_l' ... are equal, introduced by MG ! *) + real_mult_2_assoc "z1 + (z1 + k) = 2 * z1 + k" + real_mult_2_assoc_l "z1 + (z1 + k) = 2 * z1 + k" + real_mult_2_assoc_r "(k + z1) + z1 = k + 2 * z1" + + real_add_mult_distrib_poly "w is_polyexp ==> (z1 + z2) * w = z1 * w + z2 * w" + real_add_mult_distrib2_poly "w is_polyexp ==> w * (z1 + z2) = w * z1 + w * z2" +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/PolyEq.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/PolyEq.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1162 @@ +(*. (c) by Richard Lang, 2003 .*) +(* collecting all knowledge for PolynomialEquations + created by: rlang + date: 02.07 + changed by: rlang + last change by: rlang + date: 02.11.26 +*) + +(* use"Knowledge/PolyEq.ML"; + use"PolyEq.ML"; + + use"ROOT.ML"; + cd"IsacKnowledge"; + + remove_thy"PolyEq"; + use_thy"Knowledge/Isac"; + *) +"******* PolyEq.ML begin *******"; + +theory' := overwritel (!theory', [("PolyEq.thy",PolyEq.thy)]); +(*-------------------------functions---------------------*) +(* just for try +local + fun add0 l d d_ = if (d_+1) < d then add0 (str2term"0"::l) d (d_+1) else l; + fun poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("Atools.pow",_) $ v_ $ Free (d_,_)))) v l d = + if (v=v_) + then poly2list_ t1 v (((str2term("1")))::(add0 l d (int_of_str' d_))) (int_of_str' d_) + else t::(add0 l d 0) + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ + (Const ("Atools.pow",_) $ v_ $ Free (d_,_))))) v l d = + if (v=v_) + then poly2list_ t1 v (((t11))::(add0 l d (int_of_str' d_))) (int_of_str' d_) + else t::(add0 l d 0) + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Free (v_ , _)) )) v l d = + if (v = (str2term v_)) + then poly2list_ t1 v (((str2term("1")))::(add0 l d 1 )) 1 + else t::(add0 l d 0) + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ (Free (v_,_)) ))) v l d = + if (v= (str2term v_)) + then poly2list_ t1 v ( (t11)::(add0 l d 1 )) 1 + else t::(add0 l d 0) + | poly2list_ (t as (Const ("op +",_) $ _ $ _))_ l d = t::(add0 l d 0) + | poly2list_ (t as (Free (_,_))) _ l d = t::(add0 l d 0) + | poly2list_ t _ l d = t::(add0 l d 0); + + fun poly2list t v = poly2list_ t v [] 0; + fun diffpolylist_ [] _ = [] + | diffpolylist_ (x::xs) d = (str2term (if term2str(x)="0" + then "0" + else term2str(x)^"*"^str_of_int(d)))::diffpolylist_ xs (d+1); + fun diffpolylist [] = [] + | diffpolylist (x::xs) = diffpolylist_ xs 1; + (* diffpolylist(poly2list (str2term "1+ x +3*x^^^3") (str2term "x"));*) +in + +end; +*) +(*-------------------------rulse-------------------------*) +val PolyEq_prls = (*3.10.02:just the following order due to subterm evaluation*) + append_rls "PolyEq_prls" e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Tools.lhs" ,eval_lhs ""), + Calc ("Tools.rhs" ,eval_rhs ""), + Calc ("Poly.is'_expanded'_in",eval_is_expanded_in ""), + Calc ("Poly.is'_poly'_in",eval_is_poly_in ""), + Calc ("Poly.has'_degree'_in",eval_has_degree_in ""), + Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""), + (*Calc ("Atools.occurs'_in",eval_occurs_in ""), *) + (*Calc ("Atools.is'_const",eval_const "#is_const_"),*) + Calc ("op =",eval_equal "#equal_"), + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), + Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false), + Thm ("or_true",num_str or_true), + Thm ("or_false",num_str or_false) + ]; + +val PolyEq_erls = + merge_rls "PolyEq_erls" LinEq_erls + (append_rls "ops_preds" calculate_Rational + [Calc ("op =",eval_equal "#equal_"), + Thm ("plus_leq", num_str plus_leq), + Thm ("minus_leq", num_str minus_leq), + Thm ("rat_leq1", num_str rat_leq1), + Thm ("rat_leq2", num_str rat_leq2), + Thm ("rat_leq3", num_str rat_leq3) + ]); + +val PolyEq_crls = + merge_rls "PolyEq_crls" LinEq_crls + (append_rls "ops_preds" calculate_Rational + [Calc ("op =",eval_equal "#equal_"), + Thm ("plus_leq", num_str plus_leq), + Thm ("minus_leq", num_str minus_leq), + Thm ("rat_leq1", num_str rat_leq1), + Thm ("rat_leq2", num_str rat_leq2), + Thm ("rat_leq3", num_str rat_leq3) + ]); +(*------ +val PolyEq_erls = + merge_rls "PolyEq_erls" + (append_rls "" (Rls {(*asm_thm=[],*)calc=[], + erls= Rls {(*asm_thm=[],*)calc=[], + erls= Erls, + id="e_rls",preconds=[], + rew_ord=("dummy_ord",dummy_ord), + rules=[Thm ("", + num_str ), + Thm ("", + num_str ), + Thm ("", + num_str ) + ], + scr=EmptyScr,srls=Erls}, + id="e_rls",preconds=[],rew_ord=("dummy_ord", + dummy_ord), + rules=[],scr=EmptyScr,srls=Erls} + ) + ((#rules o rep_rls) LinEq_erls)) + (append_rls "ops_preds" calculate_Rational + [Calc ("op =",eval_equal "#equal_"), + Thm ("plus_leq", num_str plus_leq), + Thm ("minus_leq", num_str minus_leq), + Thm ("rat_leq1", num_str rat_leq1), + Thm ("rat_leq2", num_str rat_leq2), + Thm ("rat_leq3", num_str rat_leq3) + ]); +-----*) + + +val cancel_leading_coeff = prep_rls( + Rls {id = "cancel_leading_coeff", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("cancel_leading_coeff1",num_str cancel_leading_coeff1), + Thm ("cancel_leading_coeff2",num_str cancel_leading_coeff2), + Thm ("cancel_leading_coeff3",num_str cancel_leading_coeff3), + Thm ("cancel_leading_coeff4",num_str cancel_leading_coeff4), + Thm ("cancel_leading_coeff5",num_str cancel_leading_coeff5), + Thm ("cancel_leading_coeff6",num_str cancel_leading_coeff6), + Thm ("cancel_leading_coeff7",num_str cancel_leading_coeff7), + Thm ("cancel_leading_coeff8",num_str cancel_leading_coeff8), + Thm ("cancel_leading_coeff9",num_str cancel_leading_coeff9), + Thm ("cancel_leading_coeff10",num_str cancel_leading_coeff10), + Thm ("cancel_leading_coeff11",num_str cancel_leading_coeff11), + Thm ("cancel_leading_coeff12",num_str cancel_leading_coeff12), + Thm ("cancel_leading_coeff13",num_str cancel_leading_coeff13) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +val complete_square = prep_rls( + Rls {id = "complete_square", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("complete_square1",num_str complete_square1), + Thm ("complete_square2",num_str complete_square2), + Thm ("complete_square3",num_str complete_square3), + Thm ("complete_square4",num_str complete_square4), + Thm ("complete_square5",num_str complete_square5) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("cancel_leading_coeff",cancel_leading_coeff), + ("complete_square",complete_square), + ("PolyEq_erls",PolyEq_erls)(*FIXXXME:del with rls.rls'*) + ]); +val polyeq_simplify = prep_rls( + Rls {id = "polyeq_simplify", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_assoc_1",num_str real_assoc_1), + Thm ("real_assoc_2",num_str real_assoc_2), + Thm ("real_diff_minus",num_str real_diff_minus), + Thm ("real_unari_minus",num_str real_unari_minus), + Thm ("realpow_multI",num_str realpow_multI), + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + Rls_ reduce_012 + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("polyeq_simplify",polyeq_simplify)]); + + +(* ------------- polySolve ------------------ *) +(* -- d0 -- *) +(*isolate the bound variable in an d0 equation; 'bdv' is a meta-constant*) +val d0_polyeq_simplify = prep_rls( + Rls {id = "d0_polyeq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm("d0_true",num_str d0_true), + Thm("d0_false",num_str d0_false) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* -- d1 -- *) +(*isolate the bound variable in an d1 equation; 'bdv' is a meta-constant*) +val d1_polyeq_simplify = prep_rls( + Rls {id = "d1_polyeq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d1_isolate_div","")],*) + rules = [ + Thm("d1_isolate_add1",num_str d1_isolate_add1), + (* a+bx=0 -> bx=-a *) + Thm("d1_isolate_add2",num_str d1_isolate_add2), + (* a+ x=0 -> x=-a *) + Thm("d1_isolate_div",num_str d1_isolate_div) + (* bx=c -> x=c/b *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* -- d2 -- *) +(*isolate the bound variable in an d2 equation with bdv only; 'bdv' is a meta-constant*) +val d2_polyeq_bdv_only_simplify = prep_rls( + Rls {id = "d2_polyeq_bdv_only_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), + ("d2_isolate_div","")],*) + rules = [ + Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *) + Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *) + Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *) + Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *) + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg), (* [0 [] *) + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) + Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*) + Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*) + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(*isolate the bound variable in an d2 equation with sqrt only; 'bdv' is a meta-constant*) +val d2_polyeq_sq_only_simplify = prep_rls( + Rls {id = "d2_polyeq_sq_only_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), + ("d2_isolate_div","")],*) + rules = [ + Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*) + Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*) + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[] *) + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(*isolate the bound variable in an d2 equation with pqFormula; 'bdv' is a meta-constant*) +val d2_polyeq_pqFormula_simplify = prep_rls( + Rls {id = "d2_polyeq_pqFormula_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), + ("d2_pqformula5",""),("d2_pqformula6",""),("d2_pqformula7",""),("d2_pqformula8",""), + ("d2_pqformula9",""),("d2_pqformula10",""), + ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), + ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),("d2_pqformula10_neg","")],*) + rules = [ + Thm("d2_pqformula1",num_str d2_pqformula1), (* q+px+ x^2=0 *) + Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* q+px+ x^2=0 *) + Thm("d2_pqformula2",num_str d2_pqformula2), (* q+px+1x^2=0 *) + Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* q+px+1x^2=0 *) + Thm("d2_pqformula3",num_str d2_pqformula3), (* q+ x+ x^2=0 *) + Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* q+ x+ x^2=0 *) + Thm("d2_pqformula4",num_str d2_pqformula4), (* q+ x+1x^2=0 *) + Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* q+ x+1x^2=0 *) + Thm("d2_pqformula5",num_str d2_pqformula5), (* qx+ x^2=0 *) + Thm("d2_pqformula6",num_str d2_pqformula6), (* qx+1x^2=0 *) + Thm("d2_pqformula7",num_str d2_pqformula7), (* x+ x^2=0 *) + Thm("d2_pqformula8",num_str d2_pqformula8), (* x+1x^2=0 *) + Thm("d2_pqformula9",num_str d2_pqformula9), (* q +1x^2=0 *) + Thm("d2_pqformula9_neg",num_str d2_pqformula9_neg), (* q +1x^2=0 *) + Thm("d2_pqformula10",num_str d2_pqformula10), (* q + x^2=0 *) + Thm("d2_pqformula10_neg",num_str d2_pqformula10_neg), (* q + x^2=0 *) + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *) + Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* 1x^2=0 *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(*isolate the bound variable in an d2 equation with abcFormula; 'bdv' is a meta-constant*) +val d2_polyeq_abcFormula_simplify = prep_rls( + Rls {id = "d2_polyeq_abcFormula_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""), + ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""), + ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""), + ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), + ("d2_abcformula3_neg",""),("d2_abcformula4_neg",""),("d2_abcformula5_neg",""), + ("d2_abcformula6_neg","")],*) + rules = [ + Thm("d2_abcformula1",num_str d2_abcformula1), (*c+bx+cx^2=0 *) + Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (*c+bx+cx^2=0 *) + Thm("d2_abcformula2",num_str d2_abcformula2), (*c+ x+cx^2=0 *) + Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (*c+ x+cx^2=0 *) + Thm("d2_abcformula3",num_str d2_abcformula3), (*c+bx+ x^2=0 *) + Thm("d2_abcformula3_neg",num_str d2_abcformula3_neg), (*c+bx+ x^2=0 *) + Thm("d2_abcformula4",num_str d2_abcformula4), (*c+ x+ x^2=0 *) + Thm("d2_abcformula4_neg",num_str d2_abcformula4_neg), (*c+ x+ x^2=0 *) + Thm("d2_abcformula5",num_str d2_abcformula5), (*c+ cx^2=0 *) + Thm("d2_abcformula5_neg",num_str d2_abcformula5_neg), (*c+ cx^2=0 *) + Thm("d2_abcformula6",num_str d2_abcformula6), (*c+ x^2=0 *) + Thm("d2_abcformula6_neg",num_str d2_abcformula6_neg), (*c+ x^2=0 *) + Thm("d2_abcformula7",num_str d2_abcformula7), (* bx+ax^2=0 *) + Thm("d2_abcformula8",num_str d2_abcformula8), (* bx+ x^2=0 *) + Thm("d2_abcformula9",num_str d2_abcformula9), (* x+ax^2=0 *) + Thm("d2_abcformula10",num_str d2_abcformula10), (* x+ x^2=0 *) + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *) + Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* bx^2=0 *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(*isolate the bound variable in an d2 equation; 'bdv' is a meta-constant*) +val d2_polyeq_simplify = prep_rls( + Rls {id = "d2_polyeq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), + ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), + ("d2_pqformula4_neg",""), + ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""), + ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""), + ("d2_sqrt_equation1_neg",""),("d2_isolate_div","")],*) + rules = [ + Thm("d2_pqformula1",num_str d2_pqformula1), (* p+qx+ x^2=0 *) + Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* p+qx+ x^2=0 *) + Thm("d2_pqformula2",num_str d2_pqformula2), (* p+qx+1x^2=0 *) + Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* p+qx+1x^2=0 *) + Thm("d2_pqformula3",num_str d2_pqformula3), (* p+ x+ x^2=0 *) + Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* p+ x+ x^2=0 *) + Thm("d2_pqformula4",num_str d2_pqformula4), (* p+ x+1x^2=0 *) + Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* p+ x+1x^2=0 *) + Thm("d2_abcformula1",num_str d2_abcformula1), (* c+bx+cx^2=0 *) + Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (* c+bx+cx^2=0 *) + Thm("d2_abcformula2",num_str d2_abcformula2), (* c+ x+cx^2=0 *) + Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (* c+ x+cx^2=0 *) + Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *) + Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *) + Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *) + Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *) + Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*) + Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*) + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*) + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[]*) + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *) + Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*) + Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*) + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* -- d3 -- *) +(*isolate the bound variable in an d3 equation; 'bdv' is a meta-constant*) +val d3_polyeq_simplify = prep_rls( + Rls {id = "d3_polyeq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [("d3_isolate_div","")],*) + rules = [ + Thm("d3_reduce_equation1",num_str d3_reduce_equation1), + (*a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation2",num_str d3_reduce_equation2), + (* bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation3",num_str d3_reduce_equation3), + (*a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation4",num_str d3_reduce_equation4), + (* bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation5",num_str d3_reduce_equation5), + (*a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0)*) + Thm("d3_reduce_equation6",num_str d3_reduce_equation6), + (* bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0)*) + Thm("d3_reduce_equation7",num_str d3_reduce_equation7), + (*a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*) + Thm("d3_reduce_equation8",num_str d3_reduce_equation8), + (* bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*) + Thm("d3_reduce_equation9",num_str d3_reduce_equation9), + (*a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0)*) + Thm("d3_reduce_equation10",num_str d3_reduce_equation10), + (* bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0)*) + Thm("d3_reduce_equation11",num_str d3_reduce_equation11), + (*a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0)*) + Thm("d3_reduce_equation12",num_str d3_reduce_equation12), + (* bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0)*) + Thm("d3_reduce_equation13",num_str d3_reduce_equation13), + (* b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation14",num_str d3_reduce_equation14), + (* bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0)*) + Thm("d3_reduce_equation15",num_str d3_reduce_equation15), + (* b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0)*) + Thm("d3_reduce_equation16",num_str d3_reduce_equation16), + (* bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0)*) + Thm("d3_isolate_add1",num_str d3_isolate_add1), + (*[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (bdv=0 | (b*bdv^^^3=a)*) + Thm("d3_isolate_add2",num_str d3_isolate_add2), + (*[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = (bdv=0 | ( bdv^^^3=a)*) + Thm("d3_isolate_div",num_str d3_isolate_div), + (*[|Not(b=0)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b*) + Thm("d3_root_equation2",num_str d3_root_equation2), + (*(bdv^^^3=0) = (bdv=0) *) + Thm("d3_root_equation1",num_str d3_root_equation1) + (*bdv^^^3=c) = (bdv = nroot 3 c*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* -- d4 -- *) +(*isolate the bound variable in an d4 equation; 'bdv' is a meta-constant*) +val d4_polyeq_simplify = prep_rls( + Rls {id = "d4_polyeq_simplify", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = PolyEq_erls, + srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm("d4_sub_u1",num_str d4_sub_u1) + (* ax^4+bx^2+c=0 -> x=+-sqrt(ax^2+bx^+c) *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); + +ruleset' := overwritelthy thy (!ruleset', + [("d0_polyeq_simplify", d0_polyeq_simplify), + ("d1_polyeq_simplify", d1_polyeq_simplify), + ("d2_polyeq_simplify", d2_polyeq_simplify), + ("d2_polyeq_bdv_only_simplify", d2_polyeq_bdv_only_simplify), + ("d2_polyeq_sq_only_simplify", d2_polyeq_sq_only_simplify), + ("d2_polyeq_pqFormula_simplify", d2_polyeq_pqFormula_simplify), + ("d2_polyeq_abcFormula_simplify", d2_polyeq_abcFormula_simplify), + ("d3_polyeq_simplify", d3_polyeq_simplify), + ("d4_polyeq_simplify", d4_polyeq_simplify) + ]); + +(*------------------------problems------------------------*) +(* +(get_pbt ["degree_2","polynomial","univariate","equation"]); +show_ptyps(); +*) + +(*-------------------------poly-----------------------*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly" [] e_pblID + (["polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["~((e_::bool) is_ratequation_in (v_::real))", + "~((lhs e_) is_rootTerm_in (v_::real))", + "~((rhs e_) is_rootTerm_in (v_::real))"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [])); +(*--- d0 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg0" [] e_pblID + (["degree_0","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_poly_in v_", + "((lhs e_) has_degree_in v_ ) = 0" + ]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d0_polyeq_equation"]])); + +(*--- d1 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg1" [] e_pblID + (["degree_1","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_poly_in v_", + "((lhs e_) has_degree_in v_ ) = 1" + ]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d1_polyeq_equation"]])); + +(*--- d2 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2" [] e_pblID + (["degree_2","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_ ) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d2_polyeq_equation"]])); + + store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_sqonly" [] e_pblID + (["sq_only","degree_2","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches ( ?a + ?v_^^^2 = 0) e_ | \ + \matches ( ?a + ?b*?v_^^^2 = 0) e_ | \ + \matches ( ?v_^^^2 = 0) e_ | \ + \matches ( ?b*?v_^^^2 = 0) e_" , + "Not (matches (?a + ?v_ + ?v_^^^2 = 0) e_) &\ + \Not (matches (?a + ?b*?v_ + ?v_^^^2 = 0) e_) &\ + \Not (matches (?a + ?v_ + ?c*?v_^^^2 = 0) e_) &\ + \Not (matches (?a + ?b*?v_ + ?c*?v_^^^2 = 0) e_) &\ + \Not (matches ( ?v_ + ?v_^^^2 = 0) e_) &\ + \Not (matches ( ?b*?v_ + ?v_^^^2 = 0) e_) &\ + \Not (matches ( ?v_ + ?c*?v_^^^2 = 0) e_) &\ + \Not (matches ( ?b*?v_ + ?c*?v_^^^2 = 0) e_)"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d2_polyeq_sqonly_equation"]])); + +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_bdvonly" [] e_pblID + (["bdv_only","degree_2","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a*?v_ + ?v_^^^2 = 0) e_ | \ + \matches ( ?v_ + ?v_^^^2 = 0) e_ | \ + \matches ( ?v_ + ?b*?v_^^^2 = 0) e_ | \ + \matches (?a*?v_ + ?b*?v_^^^2 = 0) e_ | \ + \matches ( ?v_^^^2 = 0) e_ | \ + \matches ( ?b*?v_^^^2 = 0) e_ "]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d2_polyeq_bdvonly_equation"]])); + +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_pq" [] e_pblID + (["pqFormula","degree_2","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a + 1*?v_^^^2 = 0) e_ | \ + \matches (?a + ?v_^^^2 = 0) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d2_polyeq_pq_equation"]])); + +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_abc" [] e_pblID + (["abcFormula","degree_2","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a + ?v_^^^2 = 0) e_ | \ + \matches (?a + ?b*?v_^^^2 = 0) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d2_polyeq_abc_equation"]])); + +(*--- d3 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg3" [] e_pblID + (["degree_3","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 3"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","solve_d3_polyeq_equation"]])); + +(*--- d4 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg4" [] e_pblID + (["degree_4","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 4"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [(*["PolyEq","solve_d4_polyeq_equation"]*)])); + +(*--- normalize ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_norm" [] e_pblID + (["normalize","polynomial","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\ + \(Not(((lhs e_) is_poly_in v_)))"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","normalize_poly"]])); +(*-------------------------expanded-----------------------*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_expand" [] e_pblID + (["expanded","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "(lhs e_) is_expanded_in v_ "]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [])); + +(*--- d2 ---*) +store_pbt + (prep_pbt PolyEq.thy "pbl_equ_univ_expand_deg2" [] e_pblID + (["degree_2","expanded","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + PolyEq_prls, SOME "solve (e_::bool, v_)", + [["PolyEq","complete_square"]])); + + +"-------------------------methods-----------------------"; +store_met + (prep_met PolyEq.thy "met_polyeq" [] e_metID + (["PolyEq"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=PolyEq_crls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); + +store_met + (prep_met PolyEq.thy "met_polyeq_norm" [] e_metID + (["PolyEq","normalize_poly"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\ + \(Not(((lhs e_) is_poly_in v_)))"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[], + crls=PolyEq_crls, nrls=norm_Rational(*, + asm_rls=[], + asm_thm=[]*)}, + (*RL: Ratpoly loest Brueche ohne bdv*) + "Script Normalize_poly (e_::bool) (v_::real) = \ + \(let e_ =((Try (Rewrite all_left False)) @@ \ + \ (Try (Repeat (Rewrite makex1_x False))) @@ \ + \ (Try (Repeat (Rewrite_Set expand_binoms False))) @@ \ + \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ make_ratpoly_in False))) @@ \ + \ (Try (Repeat (Rewrite_Set polyeq_simplify False)))) e_ \ + \ in (SubProblem (PolyEq_,[polynomial,univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_]))" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d0" [] e_metID + (["PolyEq","solve_d0_polyeq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 0"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + asm_rls=[], + asm_thm=[]*)}, + "Script Solve_d0_polyeq_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d0_polyeq_simplify False))) e_ \ + \ in ((Or_to_List e_)::bool list))" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d1" [] e_metID + (["PolyEq","solve_d1_polyeq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 1"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (* asm_rls=["d1_polyeq_simplify"],*) + asm_rls=[], + asm_thm=[("d1_isolate_div","")]*)}, + "Script Solve_d1_polyeq_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d1_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d22" [] e_metID + (["PolyEq","solve_d2_polyeq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (*asm_rls=["d2_polyeq_simplify","d1_polyeq_simplify"],*) + asm_rls=[], + asm_thm = [("d1_isolate_div",""),("d2_pqformula1",""),("d2_pqformula2",""), + ("d2_pqformula3",""),("d2_pqformula4",""),("d2_pqformula1_neg",""), + ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),("d2_pqformula4_neg",""), + ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""), + ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""), + ("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)}, + "Script Solve_d2_polyeq_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d1_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d2_bdvonly" [] e_metID + (["PolyEq","solve_d2_polyeq_bdvonly_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (*asm_rls=["d2_polyeq_bdv_only_simplify","d1_polyeq_simplify "],*) + asm_rls=[], + asm_thm=[("d1_isolate_div",""),("d2_isolate_div",""), + ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg","")]*)}, + "Script Solve_d2_polyeq_bdvonly_equation (e_::bool) (v_::real) =\ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_bdv_only_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d1_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d2_sqonly" [] e_metID + (["PolyEq","solve_d2_polyeq_sqonly_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (*asm_rls=["d2_polyeq_sq_only_simplify"],*) + asm_rls=[], + asm_thm=[("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), + ("d2_isolate_div","")]*)}, + "Script Solve_d2_polyeq_sqonly_equation (e_::bool) (v_::real) =\ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_sq_only_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_; \ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d2_pq" [] e_metID + (["PolyEq","solve_d2_polyeq_pq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (*asm_rls=["d2_polyeq_pqFormula_simplify"],*) + asm_rls=[], + asm_thm=[("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""), + ("d2_pqformula4",""),("d2_pqformula5",""),("d2_pqformula6",""), + ("d2_pqformula7",""),("d2_pqformula8",""),("d2_pqformula9",""), + ("d2_pqformula10",""),("d2_pqformula1_neg",""),("d2_pqformula2_neg",""), + ("d2_pqformula3_neg",""), ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""), + ("d2_pqformula10_neg","")]*)}, + "Script Solve_d2_polyeq_pq_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_pqFormula_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d2_abc" [] e_metID + (["PolyEq","solve_d2_polyeq_abc_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (*asm_rls=["d2_polyeq_abcFormula_simplify"],*) + asm_rls=[], + asm_thm=[("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""), + ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""), + ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""), + ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), + ("d2_abcformula3_neg",""), ("d2_abcformula4_neg",""),("d2_abcformula5_neg",""), + ("d2_abcformula6_neg","")]*)}, + "Script Solve_d2_polyeq_abc_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_abcFormula_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + +store_met + (prep_met PolyEq.thy "met_polyeq_d3" [] e_metID + (["PolyEq","solve_d3_polyeq_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_poly_in v_ ", + "((lhs e_) has_degree_in v_) = 3"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=PolyEq_erls, + srls=e_rls, + prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + (* asm_rls=["d1_polyeq_simplify","d2_polyeq_simplify","d1_polyeq_simplify"],*) + asm_rls=[], + asm_thm=[("d3_isolate_div",""),("d1_isolate_div",""),("d2_pqformula1",""), + ("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""), + ("d2_pqformula1_neg",""), ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""), + ("d2_pqformula4_neg",""), ("d2_abcformula1",""),("d2_abcformula2",""), + ("d2_abcformula1_neg",""),("d2_abcformula2_neg",""), + ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)}, + "Script Solve_d3_polyeq_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d3_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d2_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \ + \ d1_polyeq_simplify True)) @@ \ + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \ + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\ + \ (L_::bool list) = ((Or_to_List e_)::bool list) \ + \ in Check_elementwise L_ {(v_::real). Assumptions} )" + )); + + (*.solves all expanded (ie. normalized) terms of degree 2.*) + (*Oct.02 restriction: 'eval_true 0 =< discriminant' ony for integer values + by 'PolyEq_erls'; restricted until Float.thy is implemented*) +store_met + (prep_met PolyEq.thy "met_polyeq_complsq" [] e_metID + (["PolyEq","complete_square"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = 0) e_", + "((lhs e_) has_degree_in v_) = 2"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls, + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))], + crls=PolyEq_crls, nrls=norm_Rational(*, + asm_rls=[], + asm_thm=[("root_plus_minus","")]*)}, + "Script Complete_square (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\ + \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \ + \ @@ (Try (Rewrite square_explicit1 False)) \ + \ @@ (Try (Rewrite square_explicit2 False)) \ + \ @@ (Rewrite root_plus_minus True) \ + \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False))) \ + \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \ + \ @@ (Try (Repeat \ + \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \ + \ @@ (Try (Rewrite_Set calculate_RootRat False)) \ + \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \ + \ in ((Or_to_List e_)::bool list))" + )); +(*6.10.02: x^2=64: root_plus_minus -/-/-> + "Script Complete_square (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\ + \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \ + \ @@ (Try ((Rewrite square_explicit1 False) \ + \ Or (Rewrite square_explicit2 False))) \ + \ @@ (Rewrite root_plus_minus True) \ + \ @@ ((Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False)) \ + \ Or (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \ + \ @@ (Try (Repeat \ + \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \ + \ @@ (Try (Rewrite_Set calculate_RootRat False)) \ + \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \ + \ in ((Or_to_List e_)::bool list))"*) + +"******* PolyEq.ML end *******"; + +(*eine gehackte termorder*) +local (*. for make_polynomial_in .*) + +open Term; (* for type order = EQUAL | LESS | GREATER *) + +fun pr_ord EQUAL = "EQUAL" + | pr_ord LESS = "LESS" + | pr_ord GREATER = "GREATER"; + +fun dest_hd' x (Const (a, T)) = (((a, 0), T), 0) + | dest_hd' x (t as Free (a, T)) = + if x = t then ((("|||||||||||||", 0), T), 0) (*WN*) + else (((a, 0), T), 1) + | dest_hd' x (Var v) = (v, 2) + | dest_hd' x (Bound i) = ((("", i), dummyT), 3) + | dest_hd' x (Abs (_, T, _)) = ((("", 0), T), 4); + +fun size_of_term' x (Const ("Atools.pow",_) $ Free (var,_) $ Free (pot,_)) = + (case x of (*WN*) + (Free (xstr,_)) => + (if xstr = var then 1000*(the (int_of_str pot)) else 3) + | _ => raise error ("size_of_term' called with subst = "^ + (term2str x))) + | size_of_term' x (Free (subst,_)) = + (case x of + (Free (xstr,_)) => (if xstr = subst then 1000 else 1) + | _ => raise error ("size_of_term' called with subst = "^ + (term2str x))) + | size_of_term' x (Abs (_,_,body)) = 1 + size_of_term' x body + | size_of_term' x (f$t) = size_of_term' x f + size_of_term' x t + | size_of_term' x _ = 1; + + +fun term_ord' x pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) + (case term_ord' x pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) + | term_ord' x pr thy (t, u) = + (if pr then + let + val (f, ts) = strip_comb t and (g, us) = strip_comb u; + val _=writeln("t= f@ts= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ + (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\""); + val _=writeln("u= g@us= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ + (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\""); + val _=writeln("size_of_term(t,u)= ("^ + (string_of_int(size_of_term' x t))^", "^ + (string_of_int(size_of_term' x u))^")"); + val _=writeln("hd_ord(f,g) = "^((pr_ord o (hd_ord x))(f,g))); + val _=writeln("terms_ord(ts,us) = "^ + ((pr_ord o (terms_ord x) str false)(ts,us))); + val _=writeln("-------"); + in () end + else (); + case int_ord (size_of_term' x t, size_of_term' x u) of + EQUAL => + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in + (case hd_ord x (f, g) of EQUAL => (terms_ord x str pr) (ts, us) + | ord => ord) + end + | ord => ord) +and hd_ord x (f, g) = (* ~ term.ML *) + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' x f, + dest_hd' x g) +and terms_ord x str pr (ts, us) = + list_ord (term_ord' x pr (assoc_thy "Isac.thy"))(ts, us); +(*val x = (term_of o the o (parse thy)) "x"; (*FIXXXXXXME*) +*) + +in + +fun ord_make_polynomial_in (pr:bool) thy subst tu = + let + (* val _=writeln("*** subs variable is: "^(subst2str subst)); *) + in + case subst of + (_,x)::_ => (term_ord' x pr thy tu = LESS) + | _ => raise error ("ord_make_polynomial_in called with subst = "^ + (subst2str subst)) + end; +end; + +val order_add_mult_in = prep_rls( + Rls{id = "order_add_mult_in", preconds = [], + rew_ord = ("ord_make_polynomial_in", + ord_make_polynomial_in false Poly.thy), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_mult_commute",num_str real_mult_commute), + (* z * w = w * z *) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) + Thm ("real_mult_assoc",num_str real_mult_assoc), + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) + Thm ("real_add_commute",num_str real_add_commute), + (*z + w = w + z*) + Thm ("real_add_left_commute",num_str real_add_left_commute), + (*x + (y + z) = y + (x + z)*) + Thm ("real_add_assoc",num_str real_add_assoc) + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) + ], scr = EmptyScr}:rls); + +val collect_bdv = prep_rls( + Rls{id = "collect_bdv", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("bdv_collect_1",num_str bdv_collect_1), + Thm ("bdv_collect_2",num_str bdv_collect_2), + Thm ("bdv_collect_3",num_str bdv_collect_3), + + Thm ("bdv_collect_assoc1_1",num_str bdv_collect_assoc1_1), + Thm ("bdv_collect_assoc1_2",num_str bdv_collect_assoc1_2), + Thm ("bdv_collect_assoc1_3",num_str bdv_collect_assoc1_3), + + Thm ("bdv_collect_assoc2_1",num_str bdv_collect_assoc2_1), + Thm ("bdv_collect_assoc2_2",num_str bdv_collect_assoc2_2), + Thm ("bdv_collect_assoc2_3",num_str bdv_collect_assoc2_3), + + + Thm ("bdv_n_collect_1",num_str bdv_n_collect_1), + Thm ("bdv_n_collect_2",num_str bdv_n_collect_2), + Thm ("bdv_n_collect_3",num_str bdv_n_collect_3), + + Thm ("bdv_n_collect_assoc1_1",num_str bdv_n_collect_assoc1_1), + Thm ("bdv_n_collect_assoc1_2",num_str bdv_n_collect_assoc1_2), + Thm ("bdv_n_collect_assoc1_3",num_str bdv_n_collect_assoc1_3), + + Thm ("bdv_n_collect_assoc2_1",num_str bdv_n_collect_assoc2_1), + Thm ("bdv_n_collect_assoc2_2",num_str bdv_n_collect_assoc2_2), + Thm ("bdv_n_collect_assoc2_3",num_str bdv_n_collect_assoc2_3) + ], scr = EmptyScr}:rls); + +(*.transforms an arbitrary term without roots to a polynomial [4] + according to knowledge/Poly.sml.*) +val make_polynomial_in = prep_rls( + Seq {id = "make_polynomial_in", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [], (*asm_thm = [],*) + rules = [Rls_ expand_poly, + Rls_ order_add_mult_in, + Rls_ simplify_power, + Rls_ collect_numerals, + Rls_ reduce_012, + Thm ("realpow_oneI",num_str realpow_oneI), + Rls_ discard_parentheses, + Rls_ collect_bdv + ], + scr = EmptyScr + }:rls); + +val separate_bdvs = + append_rls "separate_bdvs" + collect_bdv + [Thm ("separate_bdv", num_str separate_bdv), + (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*) + Thm ("separate_bdv_n", num_str separate_bdv_n), + Thm ("separate_1_bdv", num_str separate_1_bdv), + (*"?bdv / ?b = (1 / ?b) * ?bdv"*) + Thm ("separate_1_bdv_n", num_str separate_1_bdv_n), + (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*) + Thm ("real_add_divide_distrib", + num_str real_add_divide_distrib) + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z" + WN051031 DOES NOT BELONG TO HERE*) + ]; +val make_ratpoly_in = prep_rls( + Seq {id = "make_ratpoly_in", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [], (*asm_thm = [],*) + rules = [Rls_ norm_Rational, + Rls_ order_add_mult_in, + Rls_ discard_parentheses, + Rls_ separate_bdvs, + (* Rls_ rearrange_assoc, WN060916 why does cancel_p not work?*) + Rls_ cancel_p + (*Calc ("HOL.divide" ,eval_cancel "#divide_") too weak!*) + ], + scr = EmptyScr}:rls); + + +ruleset' := overwritelthy thy (!ruleset', + [("order_add_mult_in", order_add_mult_in), + ("collect_bdv", collect_bdv), + ("make_polynomial_in", make_polynomial_in), + ("make_ratpoly_in", make_ratpoly_in), + ("separate_bdvs", separate_bdvs) + ]); + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/PolyEq.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/PolyEq.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,407 @@ +(*.(c) by Richard Lang, 2003 .*) +(* theory collecting all knowledge + (predicates 'is_rootEq_in', 'is_sqrt_in', 'is_ratEq_in') + for PolynomialEquations. + alternative dependencies see Isac.thy + created by: rlang + date: 02.07 + changed by: rlang + last change by: rlang + date: 03.06.03 +*) + +(* remove_thy"PolyEq"; + use_thy"Knowledge/Isac"; + use_thy"Knowledge/PolyEq"; + + remove_thy"PolyEq"; + use_thy"Isac"; + + use"ROOT.ML"; + cd"knowledge"; + *) + +PolyEq = LinEq + RootRatEq + +(*-------------------- consts ------------------------------------------------*) +consts + +(*---------scripts--------------------------*) + Complete'_square + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Complete'_square (_ _ =))// \ + \ (_))" 9) + (*----- poly ----- *) + Normalize'_poly + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Normalize'_poly (_ _=))// \ + \ (_))" 9) + Solve'_d0'_polyeq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d0'_polyeq'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d1'_polyeq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d1'_polyeq'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d2'_polyeq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d2'_polyeq'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d2'_polyeq'_sqonly'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d2'_polyeq'_sqonly'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d2'_polyeq'_bdvonly'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d2'_polyeq'_bdvonly'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d2'_polyeq'_pq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d2'_polyeq'_pq'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d2'_polyeq'_abc'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d2'_polyeq'_abc'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d3'_polyeq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d3'_polyeq'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_d4'_polyeq'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_d4'_polyeq'_equation (_ _ =))// \ + \ (_))" 9) + Biquadrat'_poly + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Biquadrat'_poly (_ _=))// \ + \ (_))" 9) + +(*-------------------- rules -------------------------------------------------*) +rules + + cancel_leading_coeff1 "Not (c =!= 0) ==> (a + b*bdv + c*bdv^^^2 = 0) = \ + \ (a/c + b/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff2 "Not (c =!= 0) ==> (a - b*bdv + c*bdv^^^2 = 0) = \ + \ (a/c - b/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff3 "Not (c =!= 0) ==> (a + b*bdv - c*bdv^^^2 = 0) = \ + \ (a/c + b/c*bdv - bdv^^^2 = 0)" + + cancel_leading_coeff4 "Not (c =!= 0) ==> (a + bdv + c*bdv^^^2 = 0) = \ + \ (a/c + 1/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff5 "Not (c =!= 0) ==> (a - bdv + c*bdv^^^2 = 0) = \ + \ (a/c - 1/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff6 "Not (c =!= 0) ==> (a + bdv - c*bdv^^^2 = 0) = \ + \ (a/c + 1/c*bdv - bdv^^^2 = 0)" + + cancel_leading_coeff7 "Not (c =!= 0) ==> ( b*bdv + c*bdv^^^2 = 0) = \ + \ ( b/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff8 "Not (c =!= 0) ==> ( b*bdv - c*bdv^^^2 = 0) = \ + \ ( b/c*bdv - bdv^^^2 = 0)" + + cancel_leading_coeff9 "Not (c =!= 0) ==> ( bdv + c*bdv^^^2 = 0) = \ + \ ( 1/c*bdv + bdv^^^2 = 0)" + cancel_leading_coeff10"Not (c =!= 0) ==> ( bdv - c*bdv^^^2 = 0) = \ + \ ( 1/c*bdv - bdv^^^2 = 0)" + + cancel_leading_coeff11"Not (c =!= 0) ==> (a + b*bdv^^^2 = 0) = \ + \ (a/b + bdv^^^2 = 0)" + cancel_leading_coeff12"Not (c =!= 0) ==> (a - b*bdv^^^2 = 0) = \ + \ (a/b - bdv^^^2 = 0)" + cancel_leading_coeff13"Not (c =!= 0) ==> ( b*bdv^^^2 = 0) = \ + \ ( bdv^^^2 = 0/b)" + + complete_square1 "(q + p*bdv + bdv^^^2 = 0) = \ + \(q + (p/2 + bdv)^^^2 = (p/2)^^^2)" + complete_square2 "( p*bdv + bdv^^^2 = 0) = \ + \( (p/2 + bdv)^^^2 = (p/2)^^^2)" + complete_square3 "( bdv + bdv^^^2 = 0) = \ + \( (1/2 + bdv)^^^2 = (1/2)^^^2)" + + complete_square4 "(q - p*bdv + bdv^^^2 = 0) = \ + \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)" + complete_square5 "(q + p*bdv - bdv^^^2 = 0) = \ + \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)" + + square_explicit1 "(a + b^^^2 = c) = ( b^^^2 = c - a)" + square_explicit2 "(a - b^^^2 = c) = (-(b^^^2) = c - a)" + + bdv_explicit1 "(a + bdv = b) = (bdv = - a + b)" + bdv_explicit2 "(a - bdv = b) = ((-1)*bdv = - a + b)" + bdv_explicit3 "((-1)*bdv = b) = (bdv = (-1)*b)" + + plus_leq "(0 <= a + b) = ((-1)*b <= a)"(*Isa?*) + minus_leq "(0 <= a - b) = ( b <= a)"(*Isa?*) + +(*-- normalize --*) + (*WN0509 compare LinEq.all_left "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"*) + all_left + "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)" + makex1_x + "a^^^1 = a" + real_assoc_1 + "a+(b+c) = a+b+c" + real_assoc_2 + "a*(b*c) = a*b*c" + +(* ---- degree 0 ----*) + d0_true + "(0=0) = True" + d0_false + "[|Not(bdv occurs_in a);Not(a=0)|] ==> (a=0) = False" +(* ---- degree 1 ----*) + d1_isolate_add1 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv = 0) = (b*bdv = (-1)*a)" + d1_isolate_add2 + "[|Not(bdv occurs_in a)|] ==> (a + bdv = 0) = ( bdv = (-1)*a)" + d1_isolate_div + "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv = c) = (bdv = c/b)" +(* ---- degree 2 ----*) + d2_isolate_add1 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^2=0) = (b*bdv^^^2= (-1)*a)" + d2_isolate_add2 + "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^2=0) = ( bdv^^^2= (-1)*a)" + d2_isolate_div + "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv^^^2=c) = (bdv^^^2=c/b)" + d2_prescind1 + "(a*bdv + b*bdv^^^2 = 0) = (bdv*(a +b*bdv)=0)" + d2_prescind2 + "(a*bdv + bdv^^^2 = 0) = (bdv*(a + bdv)=0)" + d2_prescind3 + "( bdv + b*bdv^^^2 = 0) = (bdv*(1+b*bdv)=0)" + d2_prescind4 + "( bdv + bdv^^^2 = 0) = (bdv*(1+ bdv)=0)" + (* eliminate degree 2 *) + (* thm for neg arguments in sqroot have postfix _neg *) + d2_sqrt_equation1 + "[|(0<=c);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = ((bdv=sqrt c) | (bdv=(-1)*sqrt c ))" + d2_sqrt_equation1_neg + "[|(c<0);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = False" + d2_sqrt_equation2 + "(bdv^^^2=0) = (bdv=0)" + d2_sqrt_equation3 + "(b*bdv^^^2=0) = (bdv=0)" + d2_reduce_equation1 + "(bdv*(a +b*bdv)=0) = ((bdv=0)|(a+b*bdv=0))" + d2_reduce_equation2 + "(bdv*(a + bdv)=0) = ((bdv=0)|(a+ bdv=0))" + d2_pqformula1 + "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+ bdv^^^2=0) = + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2) + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))" + d2_pqformula1_neg + "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+ bdv^^^2=0) = False" + d2_pqformula2 + "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+1*bdv^^^2=0) = + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2) + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))" + d2_pqformula2_neg + "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+1*bdv^^^2=0) = False" + d2_pqformula3 + "[|0<=1 - 4*q|] ==> (q+ bdv+ bdv^^^2=0) = + ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2) + | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))" + d2_pqformula3_neg + "[|1 - 4*q<0|] ==> (q+ bdv+ bdv^^^2=0) = False" + d2_pqformula4 + "[|0<=1 - 4*q|] ==> (q+ bdv+1*bdv^^^2=0) = + ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2) + | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))" + d2_pqformula4_neg + "[|1 - 4*q<0|] ==> (q+ bdv+1*bdv^^^2=0) = False" + d2_pqformula5 + "[|0<=p^^^2 - 0|] ==> ( p*bdv+ bdv^^^2=0) = + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2) + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))" + (* d2_pqformula5_neg not need p^2 never less zero in R *) + d2_pqformula6 + "[|0<=p^^^2 - 0|] ==> ( p*bdv+1*bdv^^^2=0) = + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2) + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))" + (* d2_pqformula6_neg not need p^2 never less zero in R *) + d2_pqformula7 + "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) = + ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2) + | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))" + (* d2_pqformula7_neg not need, because 1<0 ==> False*) + d2_pqformula8 + "[|0<=1 - 0|] ==> ( bdv+1*bdv^^^2=0) = + ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2) + | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))" + (* d2_pqformula8_neg not need, because 1<0 ==> False*) + d2_pqformula9 + "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ 1*bdv^^^2=0) = + ((bdv= 0 + sqrt(0 - 4*q)/2) + | (bdv= 0 - sqrt(0 - 4*q)/2))" + d2_pqformula9_neg + "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ 1*bdv^^^2=0) = False" + d2_pqformula10 + "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ bdv^^^2=0) = + ((bdv= 0 + sqrt(0 - 4*q)/2) + | (bdv= 0 - sqrt(0 - 4*q)/2))" + d2_pqformula10_neg + "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ bdv^^^2=0) = False" + d2_abcformula1 + "[|0<=b^^^2 - 4*a*c|] ==> (c + b*bdv+a*bdv^^^2=0) = + ((bdv=( -b + sqrt(b^^^2 - 4*a*c))/(2*a)) + | (bdv=( -b - sqrt(b^^^2 - 4*a*c))/(2*a)))" + d2_abcformula1_neg + "[|b^^^2 - 4*a*c<0|] ==> (c + b*bdv+a*bdv^^^2=0) = False" + d2_abcformula2 + "[|0<=1 - 4*a*c|] ==> (c+ bdv+a*bdv^^^2=0) = + ((bdv=( -1 + sqrt(1 - 4*a*c))/(2*a)) + | (bdv=( -1 - sqrt(1 - 4*a*c))/(2*a)))" + d2_abcformula2_neg + "[|1 - 4*a*c<0|] ==> (c+ bdv+a*bdv^^^2=0) = False" + d2_abcformula3 + "[|0<=b^^^2 - 4*1*c|] ==> (c + b*bdv+ bdv^^^2=0) = + ((bdv=( -b + sqrt(b^^^2 - 4*1*c))/(2*1)) + | (bdv=( -b - sqrt(b^^^2 - 4*1*c))/(2*1)))" + d2_abcformula3_neg + "[|b^^^2 - 4*1*c<0|] ==> (c + b*bdv+ bdv^^^2=0) = False" + d2_abcformula4 + "[|0<=1 - 4*1*c|] ==> (c + bdv+ bdv^^^2=0) = + ((bdv=( -1 + sqrt(1 - 4*1*c))/(2*1)) + | (bdv=( -1 - sqrt(1 - 4*1*c))/(2*1)))" + d2_abcformula4_neg + "[|1 - 4*1*c<0|] ==> (c + bdv+ bdv^^^2=0) = False" + d2_abcformula5 + "[|Not(bdv occurs_in c); 0<=0 - 4*a*c|] ==> (c + a*bdv^^^2=0) = + ((bdv=( 0 + sqrt(0 - 4*a*c))/(2*a)) + | (bdv=( 0 - sqrt(0 - 4*a*c))/(2*a)))" + d2_abcformula5_neg + "[|Not(bdv occurs_in c); 0 - 4*a*c<0|] ==> (c + a*bdv^^^2=0) = False" + d2_abcformula6 + "[|Not(bdv occurs_in c); 0<=0 - 4*1*c|] ==> (c+ bdv^^^2=0) = + ((bdv=( 0 + sqrt(0 - 4*1*c))/(2*1)) + | (bdv=( 0 - sqrt(0 - 4*1*c))/(2*1)))" + d2_abcformula6_neg + "[|Not(bdv occurs_in c); 0 - 4*1*c<0|] ==> (c+ bdv^^^2=0) = False" + d2_abcformula7 + "[|0<=b^^^2 - 0|] ==> ( b*bdv+a*bdv^^^2=0) = + ((bdv=( -b + sqrt(b^^^2 - 0))/(2*a)) + | (bdv=( -b - sqrt(b^^^2 - 0))/(2*a)))" + (* d2_abcformula7_neg not need b^2 never less zero in R *) + d2_abcformula8 + "[|0<=b^^^2 - 0|] ==> ( b*bdv+ bdv^^^2=0) = + ((bdv=( -b + sqrt(b^^^2 - 0))/(2*1)) + | (bdv=( -b - sqrt(b^^^2 - 0))/(2*1)))" + (* d2_abcformula8_neg not need b^2 never less zero in R *) + d2_abcformula9 + "[|0<=1 - 0|] ==> ( bdv+a*bdv^^^2=0) = + ((bdv=( -1 + sqrt(1 - 0))/(2*a)) + | (bdv=( -1 - sqrt(1 - 0))/(2*a)))" + (* d2_abcformula9_neg not need, because 1<0 ==> False*) + d2_abcformula10 + "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) = + ((bdv=( -1 + sqrt(1 - 0))/(2*1)) + | (bdv=( -1 - sqrt(1 - 0))/(2*1)))" + (* d2_abcformula10_neg not need, because 1<0 ==> False*) + +(* ---- degree 3 ----*) + d3_reduce_equation1 + "(a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0))" + d3_reduce_equation2 + "( bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0))" + d3_reduce_equation3 + "(a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0))" + d3_reduce_equation4 + "( bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0))" + d3_reduce_equation5 + "(a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0))" + d3_reduce_equation6 + "( bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0))" + d3_reduce_equation7 + "(a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))" + d3_reduce_equation8 + "( bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))" + d3_reduce_equation9 + "(a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0))" + d3_reduce_equation10 + "( bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0))" + d3_reduce_equation11 + "(a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0))" + d3_reduce_equation12 + "( bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0))" + d3_reduce_equation13 + "( b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0))" + d3_reduce_equation14 + "( bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0))" + d3_reduce_equation15 + "( b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0))" + d3_reduce_equation16 + "( bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0))" + d3_isolate_add1 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (b*bdv^^^3= (-1)*a)" + d3_isolate_add2 + "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = ( bdv^^^3= (-1)*a)" + d3_isolate_div + "[|Not(b=0);Not(bdv occurs_in a)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b)" + d3_root_equation2 + "(bdv^^^3=0) = (bdv=0)" + d3_root_equation1 + "(bdv^^^3=c) = (bdv = nroot 3 c)" + +(* ---- degree 4 ----*) + (* RL03.FIXME es wir nicht getestet ob u>0 *) + d4_sub_u1 + "(c+b*bdv^^^2+a*bdv^^^4=0) = + ((a*u^^^2+b*u+c=0) & (bdv^^^2=u))" + +(* ---- 7.3.02 von Termorder ---- *) + + bdv_collect_1 "l * bdv + m * bdv = (l + m) * bdv" + bdv_collect_2 "bdv + m * bdv = (1 + m) * bdv" + bdv_collect_3 "l * bdv + bdv = (l + 1) * bdv" + +(* bdv_collect_assoc0_1 "l * bdv + m * bdv + k = (l + m) * bdv + k" + bdv_collect_assoc0_2 "bdv + m * bdv + k = (1 + m) * bdv + k" + bdv_collect_assoc0_3 "l * bdv + bdv + k = (l + 1) * bdv + k" +*) + bdv_collect_assoc1_1 "l * bdv + (m * bdv + k) = (l + m) * bdv + k" + bdv_collect_assoc1_2 "bdv + (m * bdv + k) = (1 + m) * bdv + k" + bdv_collect_assoc1_3 "l * bdv + (bdv + k) = (l + 1) * bdv + k" + + bdv_collect_assoc2_1 "k + l * bdv + m * bdv = k + (l + m) * bdv" + bdv_collect_assoc2_2 "k + bdv + m * bdv = k + (1 + m) * bdv" + bdv_collect_assoc2_3 "k + l * bdv + bdv = k + (l + 1) * bdv" + + + bdv_n_collect_1 "l * bdv^^^n + m * bdv^^^n = (l + m) * bdv^^^n" + bdv_n_collect_2 " bdv^^^n + m * bdv^^^n = (1 + m) * bdv^^^n" + bdv_n_collect_3 "l * bdv^^^n + bdv^^^n = (l + 1) * bdv^^^n" (*order!*) + + bdv_n_collect_assoc1_1 "l * bdv^^^n + (m * bdv^^^n + k) = (l + m) * bdv^^^n + k" + bdv_n_collect_assoc1_2 "bdv^^^n + (m * bdv^^^n + k) = (1 + m) * bdv^^^n + k" + bdv_n_collect_assoc1_3 "l * bdv^^^n + (bdv^^^n + k) = (l + 1) * bdv^^^n + k" + + bdv_n_collect_assoc2_1 "k + l * bdv^^^n + m * bdv^^^n = k + (l + m) * bdv^^^n" + bdv_n_collect_assoc2_2 "k + bdv^^^n + m * bdv^^^n = k + (1 + m) * bdv^^^n" + bdv_n_collect_assoc2_3 "k + l * bdv^^^n + bdv^^^n = k + (l + 1) * bdv^^^n" + +(*WN.14.3.03*) + real_minus_div "- (a / b) = (-1 * a) / b" + + separate_bdv "(a * bdv) / b = (a / b) * bdv" + separate_bdv_n "(a * bdv ^^^ n) / b = (a / b) * bdv ^^^ n" + separate_1_bdv "bdv / b = (1 / b) * bdv" + separate_1_bdv_n "bdv ^^^ n / b = (1 / b) * bdv ^^^ n" + +end + + + + + + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/PolyMinus.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/PolyMinus.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,521 @@ +(* questionable attempts to perserve binary minus as wanted by teachers + WN071207 + (c) due to copyright terms +remove_thy"PolyMinus"; +use_thy"Knowledge/PolyMinus"; + +use_thy"Knowledge/Isac"; +use"Knowledge/PolyMinus.ML"; +*) + +(** interface isabelle -- isac **) +theory' := overwritel (!theory', [("PolyMinus.thy",PolyMinus.thy)]); + +(** eval functions **) + +(*. get the identifier from specific monomials; see fun ist_monom .*) +(*HACK.WN080107*) +fun increase str = + let val s::ss = explode str + in implode ((chr (ord s + 1))::ss) end; +fun identifier (Free (id,_)) = id (* 2, a *) + | identifier (Const ("op *", _) $ Free (num, _) $ Free (id, _)) = + id (* 2*a, a*b *) + | identifier (Const ("op *", _) $ (* 3*a*b *) + (Const ("op *", _) $ + Free (num, _) $ Free _) $ Free (id, _)) = + if is_numeral num then id + else "|||||||||||||" + | identifier (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) = + if is_numeral base then "|||||||||||||" (* a^2 *) + else (*increase*) base + | identifier (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *) + (Const ("Atools.pow", _) $ + Free (base, _) $ Free (exp, _))) = + if is_numeral num andalso not (is_numeral base) then (*increase*) base + else "|||||||||||||" + | identifier _ = "|||||||||||||"(*the "largest" string*); + +(*("kleiner", ("PolyMinus.kleiner", eval_kleiner ""))*) +(* order "by alphabet" w.r.t. var: num < (var | num*var) > (var*var | ..) *) +fun eval_kleiner _ _ (p as (Const ("PolyMinus.kleiner",_) $ a $ b)) _ = + if is_num b then + if is_num a then (*123 kleiner 32 = True !!!*) + if int_of_Free a < int_of_Free b then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + else (* -1 * -2 kleiner 0 *) + SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + else + if identifier a < identifier b then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_kleiner _ _ _ _ = NONE; + +fun ist_monom (Free (id,_)) = true + | ist_monom (Const ("op *", _) $ Free (num, _) $ Free (id, _)) = + if is_numeral num then true else false + | ist_monom _ = false; +(*. this function only accepts the most simple monoms vvvvvvvvvv .*) +fun ist_monom (Free (id,_)) = true (* 2, a *) + | ist_monom (Const ("op *", _) $ Free _ $ Free (id, _)) = (* 2*a, a*b *) + if is_numeral id then false else true + | ist_monom (Const ("op *", _) $ (* 3*a*b *) + (Const ("op *", _) $ + Free (num, _) $ Free _) $ Free (id, _)) = + if is_numeral num andalso not (is_numeral id) then true else false + | ist_monom (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) = + true (* a^2 *) + | ist_monom (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *) + (Const ("Atools.pow", _) $ + Free (base, _) $ Free (exp, _))) = + if is_numeral num then true else false + | ist_monom _ = false; + +(* is this a univariate monomial ? *) +(*("ist_monom", ("PolyMinus.ist'_monom", eval_ist_monom ""))*) +fun eval_ist_monom _ _ (p as (Const ("PolyMinus.ist'_monom",_) $ a)) _ = + if ist_monom a then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = False", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_ist_monom _ _ _ _ = NONE; + + +(** rewrite order **) + +(** rulesets **) + +val erls_ordne_alphabetisch = + append_rls "erls_ordne_alphabetisch" e_rls + [Calc ("PolyMinus.kleiner", eval_kleiner ""), + Calc ("PolyMinus.ist'_monom", eval_ist_monom "") + ]; + +val ordne_alphabetisch = + Rls{id = "ordne_alphabetisch", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], + erls = erls_ordne_alphabetisch, + rules = [Thm ("tausche_plus",num_str tausche_plus), + (*"b kleiner a ==> (b + a) = (a + b)"*) + Thm ("tausche_minus",num_str tausche_minus), + (*"b kleiner a ==> (b - a) = (-a + b)"*) + Thm ("tausche_vor_plus",num_str tausche_vor_plus), + (*"[| b ist_monom; a kleiner b |] ==> (- b + a) = (a - b)"*) + Thm ("tausche_vor_minus",num_str tausche_vor_minus), + (*"[| b ist_monom; a kleiner b |] ==> (- b - a) = (-a - b)"*) + Thm ("tausche_plus_plus",num_str tausche_plus_plus), + (*"c kleiner b ==> (a + c + b) = (a + b + c)"*) + Thm ("tausche_plus_minus",num_str tausche_plus_minus), + (*"c kleiner b ==> (a + c - b) = (a - b + c)"*) + Thm ("tausche_minus_plus",num_str tausche_minus_plus), + (*"c kleiner b ==> (a - c + b) = (a + b - c)"*) + Thm ("tausche_minus_minus",num_str tausche_minus_minus) + (*"c kleiner b ==> (a - c - b) = (a - b - c)"*) + ], scr = EmptyScr}:rls; + +val fasse_zusammen = + Rls{id = "fasse_zusammen", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), + erls = append_rls "erls_fasse_zusammen" e_rls + [Calc ("Atools.is'_const",eval_const "#is_const_")], + srls = Erls, calc = [], + rules = + [Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r), + (*"[| l is_const; m..|] ==> (k + m * n) + l * n = k + (l + m)*n"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r), + (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*) + + + Thm ("subtrahiere",num_str subtrahiere), + (*"[| l is_const; m is_const |] ==> m * v - l * v = (m - l) * v"*) + Thm ("subtrahiere_von_1",num_str subtrahiere_von_1), + (*"[| l is_const |] ==> v - l * v = (1 - l) * v"*) + Thm ("subtrahiere_1",num_str subtrahiere_1), + (*"[| l is_const; m is_const |] ==> m * v - v = (m - 1) * v"*) + + Thm ("subtrahiere_x_plus_minus",num_str subtrahiere_x_plus_minus), + (*"[| l is_const; m..|] ==> (k + m * n) - l * n = k + ( m - l) * n"*) + Thm ("subtrahiere_x_plus1_minus",num_str subtrahiere_x_plus1_minus), + (*"[| l is_const |] ==> (x + v) - l * v = x + (1 - l) * v"*) + Thm ("subtrahiere_x_plus_minus1",num_str subtrahiere_x_plus_minus1), + (*"[| m is_const |] ==> (x + m * v) - v = x + (m - 1) * v"*) + + Thm ("subtrahiere_x_minus_plus",num_str subtrahiere_x_minus_plus), + (*"[| l is_const; m..|] ==> (k - m * n) + l * n = k + (-m + l) * n"*) + Thm ("subtrahiere_x_minus1_plus",num_str subtrahiere_x_minus1_plus), + (*"[| l is_const |] ==> (x - v) + l * v = x + (-1 + l) * v"*) + Thm ("subtrahiere_x_minus_plus1",num_str subtrahiere_x_minus_plus1), + (*"[| m is_const |] ==> (x - m * v) + v = x + (-m + 1) * v"*) + + Thm ("subtrahiere_x_minus_minus",num_str subtrahiere_x_minus_minus), + (*"[| l is_const; m..|] ==> (k - m * n) - l * n = k + (-m - l) * n"*) + Thm ("subtrahiere_x_minus1_minus",num_str subtrahiere_x_minus1_minus), + (*"[| l is_const |] ==> (x - v) - l * v = x + (-1 - l) * v"*) + Thm ("subtrahiere_x_minus_minus1",num_str subtrahiere_x_minus_minus1), + (*"[| m is_const |] ==> (x - m * v) - v = x + (-m - 1) * v"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#subtr_"), + + (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen + (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *) + Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r), + (*"(k + z1) + z1 = k + 2 * z1"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + + Thm ("addiere_vor_minus",num_str addiere_vor_minus), + (*"[| l is_const; m is_const |] ==> -(l * v) + m * v = (-l + m) *v"*) + Thm ("addiere_eins_vor_minus",num_str addiere_eins_vor_minus), + (*"[| m is_const |] ==> - v + m * v = (-1 + m) * v"*) + Thm ("subtrahiere_vor_minus",num_str subtrahiere_vor_minus), + (*"[| l is_const; m is_const |] ==> -(l * v) - m * v = (-l - m) *v"*) + Thm ("subtrahiere_eins_vor_minus",num_str subtrahiere_eins_vor_minus) + (*"[| m is_const |] ==> - v - m * v = (-1 - m) * v"*) + + ], scr = EmptyScr}:rls; + +val verschoenere = + Rls{id = "verschoenere", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], + erls = append_rls "erls_verschoenere" e_rls + [Calc ("PolyMinus.kleiner", eval_kleiner "")], + rules = [Thm ("vorzeichen_minus_weg1",num_str vorzeichen_minus_weg1), + (*"l kleiner 0 ==> a + l * b = a - -l * b"*) + Thm ("vorzeichen_minus_weg2",num_str vorzeichen_minus_weg2), + (*"l kleiner 0 ==> a - l * b = a + -l * b"*) + Thm ("vorzeichen_minus_weg3",num_str vorzeichen_minus_weg3), + (*"l kleiner 0 ==> k + a - l * b = k + a + -l * b"*) + Thm ("vorzeichen_minus_weg4",num_str vorzeichen_minus_weg4), + (*"l kleiner 0 ==> k - a - l * b = k - a + -l * b"*) + + Calc ("op *", eval_binop "#mult_"), + + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + Thm ("null_minus",num_str null_minus), + (*"0 - a = -a"*) + Thm ("vor_minus_mal",num_str vor_minus_mal) + (*"- a * b = (-a) * b"*) + + (*Thm ("",num_str ),*) + (**) + ], scr = EmptyScr}:rls (*end verschoenere*); + +val klammern_aufloesen = + Rls{id = "klammern_aufloesen", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls, + rules = [Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym)), + (*"a + (b + c) = (a + b) + c"*) + Thm ("klammer_plus_minus",num_str klammer_plus_minus), + (*"a + (b - c) = (a + b) - c"*) + Thm ("klammer_minus_plus",num_str klammer_minus_plus), + (*"a - (b + c) = (a - b) - c"*) + Thm ("klammer_minus_minus",num_str klammer_minus_minus) + (*"a - (b - c) = (a - b) + c"*) + ], scr = EmptyScr}:rls; + +val klammern_ausmultiplizieren = + Rls{id = "klammern_ausmultiplizieren", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls, + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + + Thm ("klammer_mult_minus",num_str klammer_mult_minus), + (*"a * (b - c) = a * b - a * c"*) + Thm ("klammer_minus_mult",num_str klammer_minus_mult) + (*"(b - c) * a = b * a - c * a"*) + + (*Thm ("",num_str ), + (*""*)*) + ], scr = EmptyScr}:rls; + +val ordne_monome = + Rls{id = "ordne_monome", preconds = [], + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], + erls = append_rls "erls_ordne_monome" e_rls + [Calc ("PolyMinus.kleiner", eval_kleiner ""), + Calc ("Atools.is'_atom", eval_is_atom "") + ], + rules = [Thm ("tausche_mal",num_str tausche_mal), + (*"[| b is_atom; a kleiner b |] ==> (b * a) = (a * b)"*) + Thm ("tausche_vor_mal",num_str tausche_vor_mal), + (*"[| b is_atom; a kleiner b |] ==> (-b * a) = (-a * b)"*) + Thm ("tausche_mal_mal",num_str tausche_mal_mal), + (*"[| c is_atom; b kleiner c |] ==> (a * c * b) = (a * b *c)"*) + Thm ("x_quadrat",num_str x_quadrat) + (*"(x * a) * a = x * a ^^^ 2"*) + + (*Thm ("",num_str ), + (*""*)*) + ], scr = EmptyScr}:rls; + + +val rls_p_33 = + append_rls "rls_p_33" e_rls + [Rls_ ordne_alphabetisch, + Rls_ fasse_zusammen, + Rls_ verschoenere + ]; +val rls_p_34 = + append_rls "rls_p_34" e_rls + [Rls_ klammern_aufloesen, + Rls_ ordne_alphabetisch, + Rls_ fasse_zusammen, + Rls_ verschoenere + ]; +val rechnen = + append_rls "rechnen" e_rls + [Calc ("op *", eval_binop "#mult_"), + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#subtr_") + ]; + +ruleset' := +overwritelthy thy (!ruleset', + [("ordne_alphabetisch", prep_rls ordne_alphabetisch), + ("fasse_zusammen", prep_rls fasse_zusammen), + ("verschoenere", prep_rls verschoenere), + ("ordne_monome", prep_rls ordne_monome), + ("klammern_aufloesen", prep_rls klammern_aufloesen), + ("klammern_ausmultiplizieren", + prep_rls klammern_ausmultiplizieren) + ]); + +(** problems **) + +store_pbt + (prep_pbt PolyMinus.thy "pbl_vereinf_poly" [] e_pblID + (["polynom","vereinfachen"], + [], Erls, NONE, [])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_minus" [] e_pblID + (["plus_minus","polynom","vereinfachen"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp", + "Not (matchsub (?a + (?b + ?c)) t_ | \ + \ matchsub (?a + (?b - ?c)) t_ | \ + \ matchsub (?a - (?b + ?c)) t_ | \ + \ matchsub (?a + (?b - ?c)) t_ )", + "Not (matchsub (?a * (?b + ?c)) t_ | \ + \ matchsub (?a * (?b - ?c)) t_ | \ + \ matchsub ((?b + ?c) * ?a) t_ | \ + \ matchsub ((?b - ?c) * ?a) t_ )"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "prls_pbl_vereinf_poly" e_rls + [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), + Calc ("Tools.matchsub", eval_matchsub ""), + Thm ("or_true",or_true), + (*"(?a | True) = True"*) + Thm ("or_false",or_false), + (*"(?a | False) = ?a"*) + Thm ("not_true",num_str not_true), + (*"(~ True) = False"*) + Thm ("not_false",num_str not_false) + (*"(~ False) = True"*)], + SOME "Vereinfache t_", + [["simplification","for_polynomials","with_minus"]])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer" [] e_pblID + (["klammer","polynom","vereinfachen"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp", + "Not (matchsub (?a * (?b + ?c)) t_ | \ + \ matchsub (?a * (?b - ?c)) t_ | \ + \ matchsub ((?b + ?c) * ?a) t_ | \ + \ matchsub ((?b - ?c) * ?a) t_ )"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "prls_pbl_vereinf_poly_klammer" e_rls [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), + Calc ("Tools.matchsub", eval_matchsub ""), + Thm ("or_true",or_true), + (*"(?a | True) = True"*) + Thm ("or_false",or_false), + (*"(?a | False) = ?a"*) + Thm ("not_true",num_str not_true), + (*"(~ True) = False"*) + Thm ("not_false",num_str not_false) + (*"(~ False) = True"*)], + SOME "Vereinfache t_", + [["simplification","for_polynomials","with_parentheses"]])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer_mal" [] e_pblID + (["binom_klammer","polynom","vereinfachen"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*) + Calc ("Poly.is'_polyexp", eval_is_polyexp "")], + SOME "Vereinfache t_", + [["simplification","for_polynomials","with_parentheses_mult"]])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_probe" [] e_pblID + (["probe"], + [], Erls, NONE, [])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_probe_poly" [] e_pblID + (["polynom","probe"], + [("#Given" ,["Pruefe e_", "mitWert ws_"]), + ("#Where" ,["e_ is_polyexp"]), + ("#Find" ,["Geprueft p_"]) + ], + append_rls "prls_pbl_probe_poly" + e_rls [(*for preds in where_*) + Calc ("Poly.is'_polyexp", eval_is_polyexp "")], + SOME "Probe e_ ws_", + [["probe","fuer_polynom"]])); + +store_pbt + (prep_pbt PolyMinus.thy "pbl_probe_bruch" [] e_pblID + (["bruch","probe"], + [("#Given" ,["Pruefe e_", "mitWert ws_"]), + ("#Where" ,["e_ is_ratpolyexp"]), + ("#Find" ,["Geprueft p_"]) + ], + append_rls "prls_pbl_probe_bruch" + e_rls [(*for preds in where_*) + Calc ("Rational.is'_ratpolyexp", eval_is_ratpolyexp "")], + SOME "Probe e_ ws_", + [["probe","fuer_bruch"]])); + + +(** methods **) + +store_met + (prep_met PolyMinus.thy "met_simp_poly_minus" [] e_metID + (["simplification","for_polynomials","with_minus"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp", + "Not (matchsub (?a + (?b + ?c)) t_ | \ + \ matchsub (?a + (?b - ?c)) t_ | \ + \ matchsub (?a - (?b + ?c)) t_ | \ + \ matchsub (?a + (?b - ?c)) t_ )"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = append_rls "prls_met_simp_poly_minus" e_rls + [Calc ("Poly.is'_polyexp", eval_is_polyexp ""), + Calc ("Tools.matchsub", eval_matchsub ""), + Thm ("and_true",and_true), + (*"(?a & True) = ?a"*) + Thm ("and_false",and_false), + (*"(?a & False) = False"*) + Thm ("not_true",num_str not_true), + (*"(~ True) = False"*) + Thm ("not_false",num_str not_false) + (*"(~ False) = True"*)], + crls = e_rls, nrls = rls_p_33}, +"Script SimplifyScript (t_::real) = \ +\ ((Repeat((Try (Rewrite_Set ordne_alphabetisch False)) @@ \ +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ +\ (Try (Rewrite_Set verschoenere False)))) t_)" + )); + +store_met + (prep_met PolyMinus.thy "met_simp_poly_parenth" [] e_metID + (["simplification","for_polynomials","with_parentheses"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = append_rls "simplification_for_polynomials_prls" e_rls + [(*for preds in where_*) + Calc("Poly.is'_polyexp",eval_is_polyexp"")], + crls = e_rls, nrls = rls_p_34}, +"Script SimplifyScript (t_::real) = \ +\ ((Repeat((Try (Rewrite_Set klammern_aufloesen False)) @@ \ +\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \ +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ +\ (Try (Rewrite_Set verschoenere False)))) t_)" + )); + +store_met + (prep_met PolyMinus.thy "met_simp_poly_parenth_mult" [] e_metID + (["simplification","for_polynomials","with_parentheses_mult"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_polyexp"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = append_rls "simplification_for_polynomials_prls" e_rls + [(*for preds in where_*) + Calc("Poly.is'_polyexp",eval_is_polyexp"")], + crls = e_rls, nrls = rls_p_34}, +"Script SimplifyScript (t_::real) = \ +\ ((Repeat((Try (Rewrite_Set klammern_ausmultiplizieren False)) @@ \ +\ (Try (Rewrite_Set discard_parentheses False)) @@ \ +\ (Try (Rewrite_Set ordne_monome False)) @@ \ +\ (Try (Rewrite_Set klammern_aufloesen False)) @@ \ +\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \ +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \ +\ (Try (Rewrite_Set verschoenere False)))) t_)" + )); + +store_met + (prep_met PolyMinus.thy "met_probe" [] e_metID + (["probe"], + [], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = Erls, crls = e_rls, nrls = Erls}, + "empty_script")); + +store_met + (prep_met PolyMinus.thy "met_probe_poly" [] e_metID + (["probe","fuer_polynom"], + [("#Given" ,["Pruefe e_", "mitWert ws_"]), + ("#Where" ,["e_ is_polyexp"]), + ("#Find" ,["Geprueft p_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = append_rls "prls_met_probe_bruch" + e_rls [(*for preds in where_*) + Calc ("Rational.is'_ratpolyexp", + eval_is_ratpolyexp "")], + crls = e_rls, nrls = rechnen}, +"Script ProbeScript (e_::bool) (ws_::bool list) = \ +\ (let e_ = Take e_; \ +\ e_ = Substitute ws_ e_ \ +\ in (Repeat((Try (Repeat (Calculate times))) @@ \ +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate minus))))) e_)" +)); + +store_met + (prep_met PolyMinus.thy "met_probe_bruch" [] e_metID + (["probe","fuer_bruch"], + [("#Given" ,["Pruefe e_", "mitWert ws_"]), + ("#Where" ,["e_ is_ratpolyexp"]), + ("#Find" ,["Geprueft p_"]) + ], + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, + prls = append_rls "prls_met_probe_bruch" + e_rls [(*for preds in where_*) + Calc ("Rational.is'_ratpolyexp", + eval_is_ratpolyexp "")], + crls = e_rls, nrls = Erls}, + "empty_script")); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/PolyMinus.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/PolyMinus.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,114 @@ +(* attempts to perserve binary minus as wanted by Austrian teachers + WN071207 + (c) due to copyright terms +remove_thy"PolyMinus"; +use_thy_only"Knowledge/PolyMinus"; +use_thy"Knowledge/Isac"; +*) + +PolyMinus = (*Poly// due to "is_ratpolyexp" in...*) Rational + + +consts + + (*predicates for conditions in rewriting*) + kleiner :: "['a, 'a] => bool" ("_ kleiner _") + ist'_monom :: "'a => bool" ("_ ist'_monom") + + (*the CAS-command*) + Probe :: "[bool, bool list] => bool" + (*"Probe (3*a+2*b+a = 4*a+2*b) [a=1,b=2]"*) + + (*descriptions for the pbl and met*) + Pruefe :: bool => una + mitWert :: bool list => tobooll + Geprueft :: bool => una + + (*Script-name*) + ProbeScript :: "[bool, bool list, bool] \ + \=> bool" + ("((Script ProbeScript (_ _ =))// (_))" 9) + +rules + + null_minus "0 - a = -a" + vor_minus_mal "- a * b = (-a) * b" + + (*commute with invariant (a.b).c -association*) + tausche_plus "[| b ist_monom; a kleiner b |] ==> \ + \(b + a) = (a + b)" + tausche_minus "[| b ist_monom; a kleiner b |] ==> \ + \(b - a) = (-a + b)" + tausche_vor_plus "[| b ist_monom; a kleiner b |] ==> \ + \(- b + a) = (a - b)" + tausche_vor_minus "[| b ist_monom; a kleiner b |] ==> \ + \(- b - a) = (-a - b)" + tausche_plus_plus "b kleiner c ==> (a + c + b) = (a + b + c)" + tausche_plus_minus "b kleiner c ==> (a + c - b) = (a - b + c)" + tausche_minus_plus "b kleiner c ==> (a - c + b) = (a + b - c)" + tausche_minus_minus "b kleiner c ==> (a - c - b) = (a - b - c)" + + (*commute with invariant (a.b).c -association*) + tausche_mal "[| b is_atom; a kleiner b |] ==> \ + \(b * a) = (a * b)" + tausche_vor_mal "[| b is_atom; a kleiner b |] ==> \ + \(-b * a) = (-a * b)" + tausche_mal_mal "[| c is_atom; b kleiner c |] ==> \ + \(x * c * b) = (x * b * c)" + x_quadrat "(x * a) * a = x * a ^^^ 2" + + + subtrahiere "[| l is_const; m is_const |] ==> \ + \m * v - l * v = (m - l) * v" + subtrahiere_von_1 "[| l is_const |] ==> \ + \v - l * v = (1 - l) * v" + subtrahiere_1 "[| l is_const; m is_const |] ==> \ + \m * v - v = (m - 1) * v" + + subtrahiere_x_plus_minus "[| l is_const; m is_const |] ==> \ + \(x + m * v) - l * v = x + (m - l) * v" + subtrahiere_x_plus1_minus "[| l is_const |] ==> \ + \(x + v) - l * v = x + (1 - l) * v" + subtrahiere_x_plus_minus1 "[| m is_const |] ==> \ + \(x + m * v) - v = x + (m - 1) * v" + + subtrahiere_x_minus_plus "[| l is_const; m is_const |] ==> \ + \(x - m * v) + l * v = x + (-m + l) * v" + subtrahiere_x_minus1_plus "[| l is_const |] ==> \ + \(x - v) + l * v = x + (-1 + l) * v" + subtrahiere_x_minus_plus1 "[| m is_const |] ==> \ + \(x - m * v) + v = x + (-m + 1) * v" + + subtrahiere_x_minus_minus "[| l is_const; m is_const |] ==> \ + \(x - m * v) - l * v = x + (-m - l) * v" + subtrahiere_x_minus1_minus"[| l is_const |] ==> \ + \(x - v) - l * v = x + (-1 - l) * v" + subtrahiere_x_minus_minus1"[| m is_const |] ==> \ + \(x - m * v) - v = x + (-m - 1) * v" + + + addiere_vor_minus "[| l is_const; m is_const |] ==> \ + \- (l * v) + m * v = (-l + m) * v" + addiere_eins_vor_minus "[| m is_const |] ==> \ + \- v + m * v = (-1 + m) * v" + subtrahiere_vor_minus "[| l is_const; m is_const |] ==> \ + \- (l * v) - m * v = (-l - m) * v" + subtrahiere_eins_vor_minus"[| m is_const |] ==> \ + \- v - m * v = (-1 - m) * v" + + vorzeichen_minus_weg1 "l kleiner 0 ==> a + l * b = a - -1*l * b" + vorzeichen_minus_weg2 "l kleiner 0 ==> a - l * b = a + -1*l * b" + vorzeichen_minus_weg3 "l kleiner 0 ==> k + a - l * b = k + a + -1*l * b" + vorzeichen_minus_weg4 "l kleiner 0 ==> k - a - l * b = k - a + -1*l * b" + + (*klammer_plus_plus = (real_add_assoc RS sym)*) + klammer_plus_minus "a + (b - c) = (a + b) - c" + klammer_minus_plus "a - (b + c) = (a - b) - c" + klammer_minus_minus "a - (b - c) = (a - b) + c" + + klammer_mult_minus "a * (b - c) = a * b - a * c" + klammer_minus_mult "(b - c) * a = b * a - c * a" + + + +end + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RatEq.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RatEq.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,203 @@ +(*.(c) by Richard Lang, 2003 .*) +(* collecting all knowledge for RationalEquations + created by: rlang + date: 02.09 + changed by: rlang + last change by: rlang + date: 02.11.29 +*) + +(* use"Knowledge/RatEq.ML"; + use"RatEq.ML"; + remove_thy"RatEq"; + use_thy"Isac"; + + use"ROOT.ML"; + cd"IsacKnowledge"; + *) +"******* RatEq.ML begin *******"; + +theory' := overwritel (!theory', [("RatEq.thy",RatEq.thy)]); + +(*-------------------------functions-----------------------*) +(* is_rateqation_in becomes true, if a bdv is in the denominator of a fraction*) +fun is_rateqation_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun finddivide (_ $ _ $ _ $ _) v = raise error("is_rateqation_in:") + (* at the moment there is no term like this, but ....*) + | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = coeff_in b v + | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) + orelse (finddivide t2 v) + | finddivide (_ $ t1) v = (finddivide t1 v) + | finddivide _ _ = false; + in + finddivide t v + end; + +fun eval_is_ratequation_in _ _ (p as (Const ("RatEq.is'_ratequation'_in",_) $ t $ v)) _ = + if is_rateqation_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_ratequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + +(*-------------------------rulse-----------------------*) +val RatEq_prls = (*15.10.02:just the following order due to subterm evaluation*) + append_rls "RatEq_prls" e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Tools.lhs" ,eval_lhs ""), + Calc ("Tools.rhs" ,eval_rhs ""), + Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""), + Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false), + Thm ("or_true",num_str or_true), + Thm ("or_false",num_str or_false) + ]; + + +(*rls = merge_rls erls Poly_erls *) +val rateq_erls = + remove_rls "rateq_erls" (*WN: ein Hack*) + (merge_rls "is_ratequation_in" calculate_Rational + (append_rls "is_ratequation_in" + Poly_erls + [(*Calc ("HOL.divide", eval_cancel "#divide_"),*) + Calc ("RatEq.is'_ratequation'_in", + eval_is_ratequation_in "") + + ])) + [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*) + Thm ("or_commute",num_str or_commute) (*WN: ein Hack*) + ]; +ruleset' := overwritelthy thy (!ruleset', + [("rateq_erls",rateq_erls)(*FIXXXME:del with rls.rls'*) + ]); + + +val RatEq_crls = + remove_rls "RatEq_crls" (*WN: ein Hack*) + (merge_rls "is_ratequation_in" calculate_Rational + (append_rls "is_ratequation_in" + Poly_erls + [(*Calc ("HOL.divide", eval_cancel "#divide_"),*) + Calc ("RatEq.is'_ratequation'_in", + eval_is_ratequation_in "") + ])) + [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*) + Thm ("or_commute",num_str or_commute) (*WN: ein Hack*) + ]; + +val RatEq_eliminate = prep_rls( + Rls {id = "RatEq_eliminate", preconds = [], rew_ord = ("termlessI",termlessI), + erls = rateq_erls, srls = Erls, calc = [], + (*asm_thm = [("rat_mult_denominator_both",""),("rat_mult_denominator_left",""), + ("rat_mult_denominator_right","")],*) + rules = [ + Thm("rat_mult_denominator_both",num_str rat_mult_denominator_both), + (* a/b=c/d -> ad=cb *) + Thm("rat_mult_denominator_left",num_str rat_mult_denominator_left), + (* a =c/d -> ad=c *) + Thm("rat_mult_denominator_right",num_str rat_mult_denominator_right) + (* a/b=c -> a=cb *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("RatEq_eliminate",RatEq_eliminate) + ]); + + + + +val RatEq_simplify = prep_rls( + Rls {id = "RatEq_simplify", preconds = [], rew_ord = ("termlessI",termlessI), + erls = rateq_erls, srls = Erls, calc = [], + (*asm_thm = [("rat_double_rat_1",""),("rat_double_rat_2",""), + ("rat_double_rat_3","")],*) + rules = [ + Thm("real_rat_mult_1",num_str real_rat_mult_1), + (*a*(b/c) = (a*b)/c*) + Thm("real_rat_mult_2",num_str real_rat_mult_2), + (*(a/b)*(c/d) = (a*c)/(b*d)*) + Thm("real_rat_mult_3",num_str real_rat_mult_3), + (* (a/b)*c = (a*c)/b*) + Thm("real_rat_pow",num_str real_rat_pow), + (*(a/b)^^^2 = a^^^2/b^^^2*) + Thm("real_diff_minus",num_str real_diff_minus), + (* a - b = a + (-1) * b *) + Thm("rat_double_rat_1",num_str rat_double_rat_1), + (* (a / (c/d) = (a*d) / c) *) + Thm("rat_double_rat_2",num_str rat_double_rat_2), + (* ((a/b) / (c/d) = (a*d) / (b*c)) *) + Thm("rat_double_rat_3",num_str rat_double_rat_3) + (* ((a/b) / c = a / (b*c) ) *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("RatEq_simplify",RatEq_simplify) + ]); + +(*-------------------------Problem-----------------------*) +(* +(get_pbt ["rational","univariate","equation"]); +show_ptyps(); +*) +store_pbt + (prep_pbt RatEq.thy "pbl_equ_univ_rat" [] e_pblID + (["rational","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]), + ("#Find" ,["solutions v_i_"]) + ], + + RatEq_prls, SOME "solve (e_::bool, v_)", + [["RatEq","solve_rat_equation"]])); + + +(*-------------------------methods-----------------------*) +store_met + (prep_met RatEq.thy "met_rateq" [] e_metID + (["RatEq"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=RatEq_crls, nrls=norm_Rational + (*, asm_rls=[],asm_thm=[]*)}, "empty_script")); +store_met + (prep_met RatEq.thy "met_rat_eq" [] e_metID + (["RatEq","solve_rat_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=rateq_erls, + srls=e_rls, + prls=RatEq_prls, + calc=[], + crls=RatEq_crls, nrls=norm_Rational(*, + asm_rls=[], + asm_thm=[("rat_double_rat_1",""),("rat_double_rat_2",""),("rat_double_rat_3",""), + ("rat_mult_denominator_both",""),("rat_mult_denominator_left",""), + ("rat_mult_denominator_right","")]*)}, + "Script Solve_rat_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Repeat(Try (Rewrite_Set RatEq_simplify True))) @@ \ + \ (Repeat(Try (Rewrite_Set norm_Rational False))) @@ \ + \ (Repeat(Try (Rewrite_Set common_nominator_p False))) @@ \ + \ (Repeat(Try (Rewrite_Set RatEq_eliminate True)))) e_;\ + \ (L_::bool list) = (SubProblem (RatEq_,[univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_]) \ + \ in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +calclist':= overwritel (!calclist', + [("is_ratequation_in", ("RatEq.is_ratequation_in", + eval_is_ratequation_in "")) + ]); +"******* RatEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RatEq.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RatEq.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,67 @@ +(*.(c) by Richard Lang, 2003 .*) +(* theory collecting all knowledge for RationalEquations + created by: rlang + date: 02.08.12 + changed by: rlang + last change by: rlang + date: 02.11.28 +*) + +(* + RL.020812 + use_thy"knowledge/RatEq"; + use_thy"RatEq"; + use_thy_only"RatEq"; + + remove_thy"RatEq"; + use_thy"Isac"; + + use"ROOT.ML"; + cd"knowledge"; + *) +RatEq = Rational + + +(*-------------------- consts------------------------------------------------*) +consts + + is'_ratequation'_in :: "[bool, real] => bool" ("_ is'_ratequation'_in _") + + (*----------------------scripts-----------------------*) + Solve'_rat'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_rat'_equation (_ _ =))// \ + \ (_))" 9) + +(*-------------------- rules------------------------------------------------*) +rules + (* FIXME also in Poly.thy def. --> FIXED*) + (*real_diff_minus + "a - b = a + (-1) * b"*) + real_rat_mult_1 + "a*(b/c) = (a*b)/c" + real_rat_mult_2 + "(a/b)*(c/d) = (a*c)/(b*d)" + real_rat_mult_3 + "(a/b)*c = (a*c)/b" + real_rat_pow + "(a/b)^^^2 = a^^^2/b^^^2" + + rat_double_rat_1 + "[|Not(c=0); Not(d=0)|] ==> (a / (c/d) = (a*d) / c)" + rat_double_rat_2 + "[|Not(b=0);Not(c=0); Not(d=0)|] ==> ((a/b) / (c/d) = (a*d) / (b*c))" + rat_double_rat_3 + "[|Not(b=0);Not(c=0)|] ==> ((a/b) / c = a / (b*c))" + + + (* equation to same denominator *) + rat_mult_denominator_both + "[|Not(b=0); Not(d=0)|] ==> ((a::real) / b = c / d) = (a*d = c*b)" + rat_mult_denominator_left + "[|Not(d=0)|] ==> ((a::real) = c / d) = (a*d = c)" + rat_mult_denominator_right + "[|Not(b=0)|] ==> ((a::real) / b = c) = (a = c*b)" + + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Rational-WN.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Rational-WN.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,257 @@ +(*Stefan K.*) + +(*protokoll 14.3.02 -------------------------------------------------- +val ct = parse thy "(a + #1)//(#2*a^^^#2 - #2)"; +val t = (term_of o the) ct; +atomt t; +val ct = parse thy "not (#1+a)"; (*HOL.thy ?*) +val t = (term_of o the) ct; +atomt t; +val ct = parse thy "x"; (*momentan ist alles 'real'*) +val t = (term_of o the) ct; +atomty t; +val ct = parse thy "(x::int)"; (* !!! *) +val t = (term_of o the) ct; +atomty t; + +val ct = parse thy "(x::int)*(y::real)"; (*momentan ist alles 'real'*) + +val Const ("RatArith.cancel",_) $ zaehler $ nenner = t; +---------------------------------------------------------------------*) + + +(*diese vvv funktionen kommen nach src/Isa99/term.sml -------------*) +fun term2str t = + let fun ato (Const(a,T)) n = + "\n"^indent n^"Const ( "^a^")" + | ato (Free (a,T)) n = + "\n"^indent n^"Free ( "^a^", "^")" + | ato (Var ((a,ix),T)) n = + "\n"^indent n^"Var (("^a^", "^string_of_int ix^"), "^")" + | ato (Bound ix) n = + "\n"^indent n^"Bound "^string_of_int ix + | ato (Abs(a,T,body)) n = + "\n"^indent n^"Abs( "^a^",.."^ato body (n+1) + | ato (f$t') n = ato f n^ato t' (n+1) + in "\n-------------"^ato t 0^"\n" end; +fun free2int (t as Free (s, _)) = (((the o int_of_str) s) + handle _ => raise error ("free2int: "^term2str t)) + | free2int t = raise error ("free2int: "^term2str t); +(*diese ^^^ funktionen kommen nach src/Isa99/term.sml -------------*) + + +(* remark on exceptions: 'error' is implemented by Isabelle + as the typical system error *) + + +type poly = int list; + +(* transform a Isabelle-term t into internal polynomial format + preconditions for t: + a-b -> a+(-b) + x^1 -> x + term ordered ascending + parentheses right side (caused by 'ordered rewriting') + variable as power (not as product) *) + +fun mono (Const ("RatArith.pow",_) $ t1 $ t2) v g = + if t1 = v then ((replicate ((free2int t2) - g) 0) @ [1]) : poly + else raise error ("term2poly.1 "^term2str t1) + | mono (t as Const ("op *",_) $ t1 $ + (Const ("RatArith.pow",_) $ t2 $ t3)) v g = + if t2 = v then (replicate ((free2int t3) - g) 0) @ [free2int t1] + else raise error ("term2poly.2 "^term2str t) + | mono t _ _ = raise error ("term2poly.3 "^term2str t); + +fun poly (Const ("op +",_) $ t1 $ t2) v g = + let val l = mono t1 v g + in (l @ (poly t2 v ((length l) + g))) end + | poly t v g = mono t v g; + +fun term2poly (t as Free (s, _)) v = + if t = v then SOME ([0,1] : poly) else (SOME [(the o int_of_str) s] + handle _ => NONE) + | term2poly (Const ("op *",_) $ (Free (s1,_)) $ (t as Free (s2,_))) v = + if t = v then SOME [0, (the o int_of_str) s1] else NONE + | term2poly (Const ("op +",_) $ (Free (s1,_)) $ t) v = + SOME ([(the o int_of_str) s1] @ (poly t v 1)) + | term2poly t v = + SOME (poly t v 0) handle _ => NONE; + +(*tests*) +val v = (term_of o the o (parse thy)) "x::real"; +val t = (term_of o the o (parse thy)) "#-1::real"; +term2poly t v; +val t = (term_of o the o (parse thy)) "x::real"; +term2poly t v; +val t = (term_of o the o (parse thy)) "#1 * x::real"; (*FIXME: drop it*) +term2poly t v; +val t = (term_of o the o (parse thy)) "x^^^#1"; (*FIXME: drop it*) +term2poly t v; +val t = (term_of o the o (parse thy)) "x^^^#3"; +term2poly t v; +val t = (term_of o the o (parse thy)) "#3 * x^^^#3"; +term2poly t v; +val t = (term_of o the o (parse thy)) "#-1 + #3 * x^^^#3"; +term2poly t v; +val t = (term_of o the o (parse thy)) "#-1 + (#3 * x^^^#3 + #5 * x^^^#5)"; +term2poly t v; +val t = (term_of o the o (parse thy)) + "#-1 + (#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7))"; +term2poly t v; +val t = (term_of o the o (parse thy)) + "#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7)"; +term2poly t v; + + +fun is_polynomial_in t v = + case term2poly t v of SOME _ => true | NONE => false; + +(* transform the internal polynomial p into an Isabelle term t + where t meets the preconditions of term2poly +val mk_mono = + fn : typ -> of the coefficients + typ -> of the unknown + typ -> of the monomial and polynomial + typ -> of the exponent of the unknown + int -> the coefficient <> 0 + string -> the unknown + int -> the degree, i.e. the value of the exponent + term +remark: all the typs above are "RealDef.real" due to the typs of * + ^ +which may change in the future +*) +fun mk_mono cT vT pT eT c v g = + case g of + 0 => Free (str_of_int c, cT) (*will cause problems with diff.typs*) + | 1 => if c = 1 then Free (v, vT) + else Const ("op *", [cT, vT]--->pT) $ + Free (str_of_int c, cT) $ Free (v, vT) + | n => if c = 1 then (Const ("RatArith.pow", [vT, eT]--->pT) $ + Free (v, vT) $ Free (str_of_int g, eT)) + else Const ("op *", [cT, vT]--->pT) $ + Free (str_of_int c, cT) $ + (Const ("RatArith.pow", [vT, eT]--->pT) $ + Free (v, vT) $ Free (str_of_int g, eT)); +(*tests*) +val cT = HOLogic.realT; val vT = HOLogic.realT; val pT = HOLogic.realT; +val eT = HOLogic.realT; +val t = mk_mono cT vT pT eT ~5 "x" 5; +(cterm_of thy) t; +val t = mk_mono cT vT pT eT ~1 "x" 0; +(cterm_of thy) t; +val t = mk_mono cT vT pT eT 1 "x" 1; +(cterm_of thy) t; + + +fun mk_sum pT t1 t2 = Const ("op +", [pT, pT]--->pT) $ t1 $ t2; + + +fun poly2term cT vT pT eT ([p]:poly) v = mk_mono cT vT pT eT p v 0 + | poly2term cT vT pT eT (p:poly) v = + let + fun mk_poly cT vT pT eT [] t v g = t + | mk_poly cT vT pT eT [p] t v g = + if p = 0 then t + else mk_sum pT (mk_mono cT vT pT eT p v g) t + | mk_poly cT vT pT eT (p::ps) t v g = + if p = 0 then mk_poly cT vT pT eT ps t v (g-1) + else mk_poly cT vT pT eT ps + (mk_sum pT (mk_mono cT vT pT eT p v g) t) v (g-1) + val (p'::ps') = rev p + val g = (length p) - 1 + in mk_poly cT vT pT eT ps' (mk_mono cT vT pT eT p' v g) v (g-1) end; + +(*tests*) +val t = poly2term cT vT pT eT [~1] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [0,1] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [0,0,0,1] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [0,0,0,3] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [~1,0,0,3] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [~1,0,0,3,0,5] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [~1,0,0,3,0,5,0,7] "x"; +(cterm_of thy) t; +val t = poly2term cT vT pT eT [0,0,0,3,0,5,0,7] "x"; +(cterm_of thy) t; + +"***************************************************************************"; +"* reverse-rewriting 12.8.02 *"; +"***************************************************************************"; +fun rewrite_set_' thy rls put_asm ruless ct = + case ruless of + Rrls _ => raise error "rewrite_set_' not for Rrls" + | Rls _ => + let + datatype switch = Appl | Noap; + fun rew_once ruls asm ct Noap [] = (ct,asm) + | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls + | rew_once ruls asm ct apno (rul::thms) = + case rul of + Thm (thmid, thm) => + (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) + rls put_asm (thm_of_thm rul) ct of + NONE => rew_once ruls asm ct apno thms + | SOME (ct',asm') => + rew_once ruls (asm union asm') ct' Appl (rul::thms)) + | Calc (cc as (op_,_)) => + (case get_calculation_ thy cc ct of + NONE => rew_once ruls asm ct apno thms + | SOME (thmid, thm') => + let + val pairopt = + rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) + rls put_asm thm' ct; + val _ = if pairopt <> NONE then () + else raise error("rewrite_set_, rewrite_ \""^ + (string_of_thmI thm')^"\" \""^ + (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE") + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end); + val ruls = (#rules o rep_rls) ruless; + val (ct',asm') = rew_once ruls [] ct Noap ruls; + in if ct = ct' then NONE else SOME (ct',asm') end; + +(* +fun reverse_rewrite t1 t2 rls = +*) +fun rewrite_set_' thy rls put_asm ruless ct = + case ruless of + Rrls _ => raise error "rewrite_set_' not for Rrls" + | Rls _ => + let + datatype switch = Appl | Noap; + fun rew_once ruls asm ct Noap [] = (ct,asm) + | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls + | rew_once ruls asm ct apno (rul::thms) = + case rul of + Thm (thmid, thm) => + (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) + rls put_asm (thm_of_thm rul) ct of + NONE => rew_once ruls asm ct apno thms + | SOME (ct',asm') => + rew_once ruls (asm union asm') ct' Appl (rul::thms)) + | Calc (cc as (op_,_)) => + (case get_calculation_ thy cc ct of + NONE => rew_once ruls asm ct apno thms + | SOME (thmid, thm') => + let + val pairopt = + rewrite_ thy ((snd o #rew_ord o rep_rls) ruless) + rls put_asm thm' ct; + val _ = if pairopt <> NONE then () + else raise error("rewrite_set_, rewrite_ \""^ + (string_of_thmI thm')^"\" \""^ + (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE") + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end); + val ruls = (#rules o rep_rls) ruless; + val (ct',asm') = rew_once ruls [] ct Noap ruls; + in if ct = ct' then NONE else SOME (ct',asm') end; + + realpow_two; + real_mult_div_cancel1; + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Rational.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Rational.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,3786 @@ +(*.calculate in rationals: gcd, lcm, etc. + (c) Stefan Karnel 2002 + Institute for Mathematics D and Institute for Software Technology, + TU-Graz SS 2002 + Use is subject to license terms. + +use"Knowledge/Rational.ML"; +use"Rational.ML"; + +remove_thy"Rational"; +use_thy"Knowledge/Isac"; +****************************************************************.*) + +(*.***************************************************************** + Remark on notions in the documentation below: + referring to the remark on 'polynomials' in Poly.sml we use + [2] 'polynomial' normalform (Polynom) + [3] 'expanded_term' normalform (Ausmultiplizierter Term), + where normalform [2] is a special case of [3], i.e. [3] implies [2]. + Instead of + 'fraction with numerator and nominator both in normalform [2]' + 'fraction with numerator and nominator both in normalform [3]' + we say: + 'fraction in normalform [2]' + 'fraction in normalform [3]' + or + 'fraction [2]' + 'fraction [3]'. + a 'simple fraction' is a term with '/' as outmost operator and + numerator and nominator in normalform [2] or [3]. +****************************************************************.*) + +signature RATIONALI = +sig + type mv_monom + type mv_poly + val add_fraction_ : theory -> term -> (term * term list) option + val add_fraction_p_ : theory -> term -> (term * term list) option + val calculate_Rational : rls + val calc_rat_erls:rls + val cancel : rls + val cancel_ : theory -> term -> (term * term list) option + val cancel_p : rls + val cancel_p_ : theory -> term -> (term * term list) option + val common_nominator : rls + val common_nominator_ : theory -> term -> (term * term list) option + val common_nominator_p : rls + val common_nominator_p_ : theory -> term -> (term * term list) option + val eval_is_expanded : string -> 'a -> term -> theory -> + (string * term) option + val expanded2polynomial : term -> term option + val factout_ : theory -> term -> (term * term list) option + val factout_p_ : theory -> term -> (term * term list) option + val is_expanded : term -> bool + val is_polynomial : term -> bool + + val mv_gcd : (int * int list) list -> mv_poly -> mv_poly + val mv_lcm : mv_poly -> mv_poly -> mv_poly + + val norm_expanded_rat_ : theory -> term -> (term * term list) option +(*WN0602.2.6.pull into struct !!! + val norm_Rational : rls(*.normalizes an arbitrary rational term without + roots into a simple and canceled fraction + with normalform [2].*) +*) +(*val norm_rational_p : 19.10.02 missing FIXXXXXXXXXXXXME + rls (*.normalizes an rational term [2] without + roots into a simple and canceled fraction + with normalform [2].*) +*) + val norm_rational_ : theory -> term -> (term * term list) option + val polynomial2expanded : term -> term option + val rational_erls : + rls (*.evaluates an arbitrary rational term with numerals.*) + +(*WN0210???SK: fehlen Funktionen, die exportiert werden sollen ? *) +end + +(*.************************************************************************** +survey on the functions +~~~~~~~~~~~~~~~~~~~~~~~ + [2] 'polynomial' :rls | [3]'expanded_term':rls +--------------------:------------------+-------------------:----------------- + factout_p_ : | factout_ : + cancel_p_ : | cancel_ : + :cancel_p | :cancel +--------------------:------------------+-------------------:----------------- + common_nominator_p_: | common_nominator_ : + :common_nominator_p| :common_nominator + add_fraction_p_ : | add_fraction_ : +--------------------:------------------+-------------------:----------------- +???SK :norm_rational_p | :norm_rational + +This survey shows only the principal functions for reuse, and the identifiers +of the rls exported. The list below shows some more useful functions. + + +conversion from Isabelle-term to internal representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +... BITTE FORTSETZEN ... + +polynomial2expanded = ... +expanded2polynomial = ... + +remark: polynomial2expanded o expanded2polynomial = I, + where 'o' is function chaining, and 'I' is identity WN0210???SK + +functions for greatest common divisor and canceling +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +mv_gcd +factout_ +factout_p_ +cancel_ +cancel_p_ + +functions for least common multiple and addition of fractions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +mv_lcm +common_nominator_ +common_nominator_p_ +add_fraction_ (*.add 2 or more fractions.*) +add_fraction_p_ (*.add 2 or more fractions.*) + +functions for normalform of rationals +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WN0210???SK interne Funktionen f"ur norm_rational: + schaffen diese SML-Funktionen wirklich ganz allgemeine Terme ? + +norm_rational_ +norm_expanded_rat_ + +**************************************************************************.*) + + +(*##*) +structure RationalI : RATIONALI = +struct +(*##*) + +infix mem ins union; (*WN100819 updating to Isabelle2009-2*) +fun x mem [] = false + | x mem (y :: ys) = x = y orelse x mem ys; +fun (x ins xs) = if x mem xs then xs else x :: xs; +fun xs union [] = xs + | [] union ys = ys + | (x :: xs) union ys = xs union (x ins ys); + +(*. gcd of integers .*) +(* die gcd Funktion von Isabelle funktioniert nicht richtig !!! *) +fun gcd_int a b = if b=0 then a + else gcd_int b (a mod b); + +(*. univariate polynomials (uv) .*) +(*. univariate polynomials are represented as a list of the coefficent in reverse maximum degree order .*) +(*. 5 * x^5 + 4 * x^3 + 2 * x^2 + x + 19 => [19,1,2,4,0,5] .*) +type uv_poly = int list; + +(*. adds two uv polynomials .*) +fun uv_mod_add_poly ([]:uv_poly,p2:uv_poly) = p2:uv_poly + | uv_mod_add_poly (p1,[]) = p1 + | uv_mod_add_poly (x::p1,y::p2) = (x+y)::(uv_mod_add_poly(p1,p2)); + +(*. multiplies a uv polynomial with a skalar s .*) +fun uv_mod_smul_poly ([]:uv_poly,s:int) = []:uv_poly + | uv_mod_smul_poly (x::p,s) = (x*s)::(uv_mod_smul_poly(p,s)); + +(*. calculates the remainder of a polynomial divided by a skalar s .*) +fun uv_mod_rem_poly ([]:uv_poly,s) = []:uv_poly + | uv_mod_rem_poly (x::p,s) = (x mod s)::(uv_mod_smul_poly(p,s)); + +(*. calculates the degree of a uv polynomial .*) +fun uv_mod_deg ([]:uv_poly) = 0 + | uv_mod_deg p = length(p)-1; + +(*. calculates the remainder of x/p and represents it as value between -p/2 and p/2 .*) +fun uv_mod_mod2(x,p)= + let + val y=(x mod p); + in + if (y)>(p div 2) then (y)-p else + ( + if (y)<(~p div 2) then p+(y) else (y) + ) + end; + +(*.calculates the remainder for each element of a integer list divided by p.*) +fun uv_mod_list_modp [] p = [] + | uv_mod_list_modp (x::xs) p = (uv_mod_mod2(x,p))::(uv_mod_list_modp xs p); + +(*. appends an integer at the end of a integer list .*) +fun uv_mod_null (p1:int list,0) = p1 + | uv_mod_null (p1:int list,n1:int) = uv_mod_null(p1,n1-1) @ [0]; + +(*. uv polynomial division, result is (quotient, remainder) .*) +(*. only for uv_mod_divides .*) +(* FIXME: Division von x^9+x^5+1 durch x-1000 funktioniert nicht integer zu klein *) +fun uv_mod_pdiv (p1:uv_poly) ([]:uv_poly) = raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero") + | uv_mod_pdiv p1 [x] = + let + val xs=ref []; + in + if x<>0 then + ( + xs:=(uv_mod_rem_poly(p1,x)); + while length(!xs)>0 andalso hd(!xs)=0 do xs:=tl(!xs) + ) + else raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero"); + ([]:uv_poly,!xs:uv_poly) + end + | uv_mod_pdiv p1 p2 = + let + val n= uv_mod_deg(p2); + val m= ref (uv_mod_deg(p1)); + val p1'=ref (rev(p1)); + val p2'=(rev(p2)); + val lc2=hd(p2'); + val q=ref []; + val c=ref 0; + val output=ref ([],[]); + in + ( + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: Division by zero") + else + ( + if (!m)=n do + ( + c:=hd(!p1') div hd(p2'); + if !c<>0 then + ( + p1':=uv_mod_add_poly(!p1',uv_mod_null(uv_mod_smul_poly(p2',~(!c)),!m-n)); + while length(!p1')>0 andalso hd(!p1')=0 do p1':= tl(!p1'); + m:=uv_mod_deg(!p1') + ) + else m:=0 + ); + output:=(rev(!q),rev(!p1')) + ) + ); + !output + ) + end; + +(*. divides p1 by p2 in Zp .*) +fun uv_mod_pdivp (p1:uv_poly) (p2:uv_poly) p = + let + val n=uv_mod_deg(p2); + val m=ref (uv_mod_deg(uv_mod_list_modp p1 p)); + val p1'=ref (rev(p1)); + val p2'=(rev(uv_mod_list_modp p2 p)); + val lc2=hd(p2'); + val q=ref []; + val c=ref 0; + val output=ref ([],[]); + in + ( + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIVP_EXCEPTION: Division by zero") + else + ( + if (!m)=n do + ( + c:=uv_mod_mod2(hd(!p1')*(power lc2 1), p); + q:=(!c)::(!q); + p1':=uv_mod_list_modp(tl(uv_mod_add_poly(uv_mod_smul_poly(!p1',lc2), + uv_mod_smul_poly(uv_mod_smul_poly(p2',hd(!p1')),~1)))) p; + m:=(!m)-1 + ); + + while !p1'<>[] andalso hd(!p1')=0 do + ( + p1':=tl(!p1') + ); + + output:=(rev(uv_mod_list_modp (!q) (p)),rev(!p1')) + ) + ); + !output:uv_poly * uv_poly + ) + end; + +(*. calculates the remainder of p1/p2 .*) +fun uv_mod_prest (p1:uv_poly) ([]:uv_poly) = raise error("UV_MOD_PREST_EXCEPTION: Division by zero") + | uv_mod_prest [] p2 = []:uv_poly + | uv_mod_prest p1 p2 = (#2(uv_mod_pdiv p1 p2)); + +(*. calculates the remainder of p1/p2 in Zp .*) +fun uv_mod_prestp (p1:uv_poly) ([]:uv_poly) p= raise error("UV_MOD_PRESTP_EXCEPTION: Division by zero") + | uv_mod_prestp [] p2 p= []:uv_poly + | uv_mod_prestp p1 p2 p = #2(uv_mod_pdivp p1 p2 p); + +(*. calculates the content of a uv polynomial .*) +fun uv_mod_cont ([]:uv_poly) = 0 + | uv_mod_cont (x::p)= gcd_int x (uv_mod_cont(p)); + +(*. divides each coefficient of a uv polynomial by y .*) +fun uv_mod_div_list (p:uv_poly,0) = raise error("UV_MOD_DIV_LIST_EXCEPTION: Division by zero") + | uv_mod_div_list ([],y) = []:uv_poly + | uv_mod_div_list (x::p,y) = (x div y)::uv_mod_div_list(p,y); + +(*. calculates the primitiv part of a uv polynomial .*) +fun uv_mod_pp ([]:uv_poly) = []:uv_poly + | uv_mod_pp p = + let + val c=ref 0; + in + ( + c:=uv_mod_cont(p); + + if !c=0 then raise error ("RATIONALS_UV_MOD_PP_EXCEPTION: content is 0") + else uv_mod_div_list(p,!c) + ) + end; + +(*. gets the leading coefficient of a uv polynomial .*) +fun uv_mod_lc ([]:uv_poly) = 0 + | uv_mod_lc p = hd(rev(p)); + +(*. calculates the euklidean polynomial remainder sequence in Zp .*) +fun uv_mod_prs_euklid_p(p1:uv_poly,p2:uv_poly,p)= + let + val f =ref []; + val f'=ref p2; + val fi=ref []; + in + ( + f:=p2::p1::[]; + while uv_mod_deg(!f')>0 do + ( + f':=uv_mod_prestp (hd(tl(!f))) (hd(!f)) p; + if (!f')<>[] then + ( + fi:=(!f'); + f:=(!fi)::(!f) + ) + else () + ); + (!f) + + ) + end; + +(*. calculates the gcd of p1 and p2 in Zp .*) +fun uv_mod_gcd_modp ([]:uv_poly) (p2:uv_poly) p = p2:uv_poly + | uv_mod_gcd_modp p1 [] p= p1 + | uv_mod_gcd_modp p1 p2 p= + let + val p1'=ref[]; + val p2'=ref[]; + val pc=ref[]; + val g=ref []; + val d=ref 0; + val prs=ref []; + in + ( + if uv_mod_deg(p1)>=uv_mod_deg(p2) then + ( + p1':=uv_mod_list_modp (uv_mod_pp(p1)) p; + p2':=uv_mod_list_modp (uv_mod_pp(p2)) p + ) + else + ( + p1':=uv_mod_list_modp (uv_mod_pp(p2)) p; + p2':=uv_mod_list_modp (uv_mod_pp(p1)) p + ); + d:=uv_mod_mod2((gcd_int (uv_mod_cont(p1))) (uv_mod_cont(p2)), p) ; + if !d>(p div 2) then d:=(!d)-p else (); + + prs:=uv_mod_prs_euklid_p(!p1',!p2',p); + + if hd(!prs)=[] then pc:=hd(tl(!prs)) + else pc:=hd(!prs); + + g:=uv_mod_smul_poly(uv_mod_pp(!pc),!d); + !g + ) + end; + +(*. calculates the minimum of two real values x and y .*) +fun uv_mod_r_min(x,y):BasisLibrary.Real.real = if x>y then y else x; + +(*. calculates the minimum of two integer values x and y .*) +fun uv_mod_min(x,y) = if x>y then y else x; + +(*. adds the squared values of a integer list .*) +fun uv_mod_add_qu [] = 0.0 + | uv_mod_add_qu (x::p) = BasisLibrary.Real.fromInt(x)*BasisLibrary.Real.fromInt(x) + uv_mod_add_qu p; + +(*. calculates the euklidean norm .*) +fun uv_mod_norm ([]:uv_poly) = 0.0 + | uv_mod_norm p = Math.sqrt(uv_mod_add_qu(p)); + +(*. multipies two values a and b .*) +fun uv_mod_multi a b = a * b; + +(*. decides if x is a prim, the list contains all primes which are lower then x .*) +fun uv_mod_prim(x,[])= false + | uv_mod_prim(x,[y])=if ((x mod y) <> 0) then true + else false + | uv_mod_prim(x,y::ys) = if uv_mod_prim(x,[y]) + then + if uv_mod_prim(x,ys) then true + else false + else false; + +(*. gets the first prime, which is greater than p and does not divide g .*) +fun uv_mod_nextprime(g,p)= + let + val list=ref [2]; + val exit=ref 0; + val i = ref 2 + in + while (!i 0) + then + ( + list:= (!i)::(!list); + i:= (!i)+1 + ) + else i:=(!i)+1 + ) + else i:= (!i)+1 + ); + i:=(p+1); + while (!exit=0) do (* calculate next prime which does not divide g *) + ( + if uv_mod_prim(!i,!list) then + ( + if (g mod !i <> 0) + then + ( + list:= (!i)::(!list); + exit:= (!i) + ) + else i:=(!i)+1 + ) + else i:= (!i)+1 + ); + !exit + end; + +(*. decides if p1 is a factor of p2 in Zp .*) +fun uv_mod_dividesp ([]:uv_poly) (p2:uv_poly) p= raise error("UV_MOD_DIVIDESP: Division by zero") + | uv_mod_dividesp p1 p2 p= if uv_mod_prestp p2 p1 p = [] then true else false; + +(*. decides if p1 is a factor of p2 .*) +fun uv_mod_divides ([]:uv_poly) (p2:uv_poly) = raise error("UV_MOD_DIVIDES: Division by zero") + | uv_mod_divides p1 p2 = if uv_mod_prest p2 p1 = [] then true else false; + +(*. chinese remainder algorithm .*) +fun uv_mod_cra2(r1,r2,m1,m2)= + let + val c=ref 0; + val r1'=ref 0; + val d=ref 0; + val a=ref 0; + in + ( + while (uv_mod_mod2((!c)*m1,m2))<>1 do + ( + c:=(!c)+1 + ); + r1':= uv_mod_mod2(r1,m1); + d:=uv_mod_mod2(((r2-(!r1'))*(!c)),m2); + !r1'+(!d)*m1 + ) + end; + +(*. applies the chinese remainder algorithmen to the coefficients of x1 and x2 .*) +fun uv_mod_cra_2 ([],[],m1,m2) = [] + | uv_mod_cra_2 ([],x2,m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x1") + | uv_mod_cra_2 (x1,[],m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x2") + | 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)); + +(*. calculates the gcd of two uv polynomials p1' and p2' with the modular algorithm .*) +fun uv_mod_gcd (p1':uv_poly) (p2':uv_poly) = + let + val p1=ref (uv_mod_pp(p1')); + val p2=ref (uv_mod_pp(p2')); + val c=gcd_int (uv_mod_cont(p1')) (uv_mod_cont(p2')); + val temp=ref []; + val cp=ref []; + val qp=ref []; + val q=ref[]; + val pn=ref 0; + val d=ref 0; + val g1=ref 0; + val p=ref 0; + val m=ref 0; + val exit=ref 0; + val i=ref 1; + in + if length(!p1)>length(!p2) then () + else + ( + temp:= !p1; + p1:= !p2; + p2:= !temp + ); + + + d:=gcd_int (uv_mod_lc(!p1)) (uv_mod_lc(!p2)); + g1:=uv_mod_lc(!p1)*uv_mod_lc(!p2); + p:=4; + + m:=BasisLibrary.Real.ceil(2.0 * + BasisLibrary.Real.fromInt(!d) * + BasisLibrary.Real.fromInt(power 2 (uv_mod_min(uv_mod_deg(!p2),uv_mod_deg(!p1)))) * + BasisLibrary.Real.fromInt(!d) * + uv_mod_r_min(uv_mod_norm(!p1) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p1))), + uv_mod_norm(!p2) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p2))))); + + while (!exit=0) do + ( + p:=uv_mod_nextprime(!d,!p); + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)) ; + if abs(uv_mod_lc(!cp))<>1 then (* leading coefficient = 1 ? *) + ( + i:=1; + while (!i)<(!p) andalso (abs(uv_mod_mod2((uv_mod_lc(!cp)*(!i)),(!p)))<>1) do + ( + i:=(!i)+1 + ); + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p) + ) + else (); + + qp:= ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp)); + + if uv_mod_deg(!qp)=0 then (q:=[1]; exit:=1) else (); + + pn:=(!p); + q:=(!qp); + + while !pn<= !m andalso !m>(!p) andalso !exit=0 do + ( + p:=uv_mod_nextprime(!d,!p); + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)); + if uv_mod_lc(!cp)<>1 then (* leading coefficient = 1 ? *) + ( + i:=1; + while (!i)<(!p) andalso ((uv_mod_mod2((uv_mod_lc(!q)*(!i)),(!p)))<>1) do + ( + i:=(!i)+1 + ); + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p) + ) + else (); + + qp:=uv_mod_list_modp ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp) ) (!p); + if uv_mod_deg(!qp)>uv_mod_deg(!q) then + ( + (*print("degree to high!!!\n")*) + ) + else + ( + if uv_mod_deg(!qp)=uv_mod_deg(!q) then + ( + q:=uv_mod_cra_2(!q,!qp,!pn,!p); + pn:=(!pn) * !p; + q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn)); (* found already gcd ? *) + if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then (exit:=1) else () + ) + else + ( + if uv_mod_deg(!qp) [(5,[5,3,0]),(4,[3,0,2]),(2,[2,1,3]),(~1,[0,0,1]),(~19,[0,0,0])] .*) + +(*. global variables .*) +(*. order indicators .*) +val LEX_=0; (* lexicographical term order *) +val GGO_=1; (* greatest degree order *) + +(*. datatypes for internal representation.*) +type mv_monom = (int * (*.coefficient or the monom.*) + int list); (*.list of exponents) .*) +fun mv_monom2str (i, is) = "("^ int2str i^"," ^ ints2str' is ^ ")"; + +type mv_poly = mv_monom list; +fun mv_poly2str p = (strs2str' o (map mv_monom2str)) p; + +(*. help function for monom_greater and geq .*) +fun mv_mg_hlp([]) = EQUAL + | mv_mg_hlp(x::list)=if x<0 then LESS + else if x>0 then GREATER + else mv_mg_hlp(list); + +(*. adds a list of values .*) +fun mv_addlist([]) = 0 + | mv_addlist(p1) = hd(p1)+mv_addlist(tl(p1)); + +(*. tests if the monomial M1 is greater as the monomial M2 and returns a boolean value .*) +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*) +fun mv_monom_greater((M1x,M1l):mv_monom,(M2x,M2l):mv_monom,order)= + if order=LEX_ then + ( + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error") + else if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true + ) + else + if order=GGO_ then + ( + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error") + else + if mv_addlist(M1l)=mv_addlist(M2l) then if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true + else if mv_addlist(M1l)>mv_addlist(M2l) then true else false + ) + else raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Wrong Order"); + +(*. tests if the monomial X is greater as the monomial Y and returns a order value (GREATER,EQUAL,LESS) .*) +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*) +fun mv_geq order ((x1,x):mv_monom,(x2,y):mv_monom) = +let + val temp=ref EQUAL; +in + if order=LEX_ then + ( + if length(x)<>length(y) then + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error") + else + ( + temp:=mv_mg_hlp((map op- (x~~y))); + if !temp=EQUAL then + ( if x1=x2 then EQUAL + else if x1>x2 then GREATER + else LESS + ) + else (!temp) + ) + ) + else + if order=GGO_ then + ( + if length(x)<>length(y) then + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error") + else + if mv_addlist(x)=mv_addlist(y) then + (mv_mg_hlp((map op- (x~~y)))) + else if mv_addlist(x)>mv_addlist(y) then GREATER else LESS + ) + else raise error ("RATIONALS_MV_GEQ_EXCEPTION: Wrong Order") +end; + +(*. cuts the first variable from a polynomial .*) +fun mv_cut([]:mv_poly)=[]:mv_poly + | mv_cut((x,[])::list) = raise error ("RATIONALS_MV_CUT_EXCEPTION: Invalid list ") + | mv_cut((x,y::ys)::list)=(x,ys)::mv_cut(list); + +(*. leading power product .*) +fun mv_lpp([]:mv_poly,order) = [] + | mv_lpp([(x,y)],order) = y + | mv_lpp(p1,order) = #2(hd(rev(sort (mv_geq order) p1))); + +(*. leading monomial .*) +fun mv_lm([]:mv_poly,order) = (0,[]):mv_monom + | mv_lm([x],order) = x + | mv_lm(p1,order) = hd(rev(sort (mv_geq order) p1)); + +(*. leading coefficient in term order .*) +fun mv_lc2([]:mv_poly,order) = 0 + | mv_lc2([(x,y)],order) = x + | mv_lc2(p1,order) = #1(hd(rev(sort (mv_geq order) p1))); + + +(*. reverse the coefficients in mv polynomial .*) +fun mv_rev_to([]:mv_poly) = []:mv_poly + | mv_rev_to((c,e)::xs) = (c,rev(e))::mv_rev_to(xs); + +(*. leading coefficient in reverse term order .*) +fun mv_lc([]:mv_poly,order) = []:mv_poly + | mv_lc([(x,y)],order) = mv_rev_to(mv_cut(mv_rev_to([(x,y)]))) + | mv_lc(p1,order) = + let + val p1o=ref (rev(sort (mv_geq order) (mv_rev_to(p1)))); + val lp=hd(#2(hd(!p1o))); + val lc=ref []; + in + ( + while (length(!p1o)>0 andalso hd(#2(hd(!p1o)))=lp) do + ( + lc:=hd(mv_cut([hd(!p1o)]))::(!lc); + p1o:=tl(!p1o) + ); + if !lc=[] then raise error ("RATIONALS_MV_LC_EXCEPTION: lc is empty") else (); + mv_rev_to(!lc) + ) + end; + +(*. compares two powerproducts .*) +fun mv_monom_equal((_,xlist):mv_monom,(_,ylist):mv_monom) = (foldr and_) (((map op=) (xlist~~ylist)),true); + +(*. help function for mv_add .*) +fun mv_madd([]:mv_poly,[]:mv_poly,order) = []:mv_poly + | mv_madd([(0,_)],p2,order) = p2 + | mv_madd(p1,[(0,_)],order) = p1 + | mv_madd([],p2,order) = p2 + | mv_madd(p1,[],order) = p1 + | mv_madd(p1,p2,order) = + ( + if mv_monom_greater(hd(p1),hd(p2),order) + then hd(p1)::mv_madd(tl(p1),p2,order) + else if mv_monom_equal(hd(p1),hd(p2)) + then if mv_lc2(p1,order)+mv_lc2(p2,order)<>0 + then (mv_lc2(p1,order)+mv_lc2(p2,order),mv_lpp(p1,order))::mv_madd(tl(p1),tl(p2),order) + else mv_madd(tl(p1),tl(p2),order) + else hd(p2)::mv_madd(p1,tl(p2),order) + ) + +(*. adds two multivariate polynomials .*) +fun mv_add([]:mv_poly,p2:mv_poly,order) = p2 + | mv_add(p1,[],order) = p1 + | mv_add(p1,p2,order) = mv_madd(rev(sort (mv_geq order) p1),rev(sort (mv_geq order) p2), order); + +(*. monom multiplication .*) +fun mv_mmul((x1,y1):mv_monom,(x2,y2):mv_monom)=(x1*x2,(map op+) (y1~~y2)):mv_monom; + +(*. deletes all monomials with coefficient 0 .*) +fun mv_shorten([]:mv_poly,order) = []:mv_poly + | mv_shorten(x::xs,order)=mv_madd([x],mv_shorten(xs,order),order); + +(*. zeros a list .*) +fun mv_null2([])=[] + | mv_null2(x::l)=0::mv_null2(l); + +(*. multiplies two multivariate polynomials .*) +fun mv_mul([]:mv_poly,[]:mv_poly,_) = []:mv_poly + | mv_mul([],y::p2,_) = [(0,mv_null2(#2(y)))] + | mv_mul(x::p1,[],_) = [(0,mv_null2(#2(x)))] + | mv_mul(x::p1,y::p2,order) = mv_shorten(rev(sort (mv_geq order) (mv_mmul(x,y) :: (mv_mul(p1,y::p2,order) @ + mv_mul([x],p2,order)))),order); + +(*. gets the maximum value of a list .*) +fun mv_getmax([])=0 + | mv_getmax(x::p1)= let + val m=mv_getmax(p1); + in + if m>x then m + else x + end; +(*. calculates the maximum degree of an multivariate polynomial .*) +fun mv_grad([]:mv_poly) = 0 + | mv_grad(p1:mv_poly)= mv_getmax((map mv_addlist) ((map #2) p1)); + +(*. converts the sign of a value .*) +fun mv_minus(x)=(~1) * x; + +(*. converts the sign of all coefficients of a polynomial .*) +fun mv_minus2([]:mv_poly)=[]:mv_poly + | mv_minus2(p1)=(mv_minus(#1(hd(p1))),#2(hd(p1)))::(mv_minus2(tl(p1))); + +(*. searches for a negativ value in a list .*) +fun mv_is_negativ([])=false + | mv_is_negativ(x::xs)=if x<0 then true else mv_is_negativ(xs); + +(*. division of monomials .*) +fun mv_mdiv((0,[]):mv_monom,_:mv_monom)=(0,[]):mv_monom + | mv_mdiv(_,(0,[]))= raise error ("RATIONALS_MV_MDIV_EXCEPTION Division by 0 ") + | mv_mdiv(p1:mv_monom,p2:mv_monom)= + let + val c=ref (#1(p2)); + val pp=ref []; + in + ( + if !c=0 then raise error("MV_MDIV_EXCEPTION Dividing by zero") + else c:=(#1(p1) div #1(p2)); + if #1(p2)<>0 then + ( + pp:=(#2(mv_mmul((1,#2(p1)),(1,(map mv_minus) (#2(p2)))))); + if mv_is_negativ(!pp) then (0,!pp) + else (!c,!pp) + ) + else raise error("MV_MDIV_EXCEPTION Dividing by empty Polynom") + ) + end; + +(*. prints a polynom for (internal use only) .*) +fun mv_print_poly([]:mv_poly)=print("[]\n") + | mv_print_poly((x,y)::[])= print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^")\n") + | mv_print_poly((x,y)::p1) = (print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^"),");mv_print_poly(p1)); + + +(*. division of two multivariate polynomials .*) +fun mv_division([]:mv_poly,g:mv_poly,order)=([]:mv_poly,[]:mv_poly) + | mv_division(f,[],order)= raise error ("RATIONALS_MV_DIVISION_EXCEPTION Division by zero") + | mv_division(f,g,order)= + let + val r=ref []; + val q=ref []; + val g'=ref []; + val k=ref 0; + val m=ref (0,[0]); + val exit=ref 0; + in + r := rev(sort (mv_geq order) (mv_shorten(f,order))); + g':= rev(sort (mv_geq order) (mv_shorten(g,order))); + if #1(hd(!g'))=0 then raise error("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero") else (); + if (mv_monom_greater (hd(!g'),hd(!r),order)) then ([(0,mv_null2(#2(hd(f))))],(!r)) + else + ( + exit:=0; + while (if (!exit)=0 then not(mv_monom_greater (hd(!g'),hd(!r),order)) else false) do + ( + if (#1(mv_lm(!g',order)))<>0 then m:=mv_mdiv(mv_lm(!r,order),mv_lm(!g',order)) + else raise error ("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero"); + if #1(!m)<>0 then + ( + q:=(!m)::(!q); + r:=mv_add((!r),mv_minus2(mv_mul(!g',[!m],order)),order) + ) + else exit:=1; + if (if length(!r)<>0 then length(!g')<>0 else false) then () + else (exit:=1) + ); + (rev(!q),!r) + ) + end; + +(*. multiplies a polynomial with an integer .*) +fun mv_skalar_mul([]:mv_poly,c) = []:mv_poly + | mv_skalar_mul((x,y)::p1,c) = ((x * c),y)::mv_skalar_mul(p1,c); + +(*. inserts the a first variable into an polynomial with exponent v .*) +fun mv_correct([]:mv_poly,v:int)=[]:mv_poly + | mv_correct((x,y)::list,v:int)=(x,v::y)::mv_correct(list,v); + +(*. multivariate case .*) + +(*. decides if x is a factor of y .*) +fun mv_divides([]:mv_poly,[]:mv_poly)= raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero") + | mv_divides(x,[]) = raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero") + | mv_divides(x:mv_poly,y:mv_poly) = #2(mv_division(y,x,LEX_))=[]; + +(*. gets the maximum of a and b .*) +fun mv_max(a,b) = if a>b then a else b; + +(*. gets the maximum exponent of a mv polynomial in the lexicographic term order .*) +fun mv_deg([]:mv_poly) = 0 + | mv_deg(p1)= + let + val p1'=mv_shorten(p1,LEX_); + in + if length(p1')=0 then 0 + else mv_max(hd(#2(hd(p1'))),mv_deg(tl(p1'))) + end; + +(*. gets the maximum exponent of a mv polynomial in the reverse lexicographic term order .*) +fun mv_deg2([]:mv_poly) = 0 + | mv_deg2(p1)= + let + val p1'=mv_shorten(p1,LEX_); + in + if length(p1')=0 then 0 + else mv_max(hd(rev(#2(hd(p1')))),mv_deg2(tl(p1'))) + end; + +(*. evaluates the mv polynomial at the value v of the main variable .*) +fun mv_subs([]:mv_poly,v) = []:mv_poly + | mv_subs((c,e)::p1:mv_poly,v) = mv_skalar_mul(mv_cut([(c,e)]),power v (hd(e))) @ mv_subs(p1,v); + +(*. calculates the content of a uv-polynomial in mv-representation .*) +fun uv_content2([]:mv_poly) = 0 + | uv_content2((c,e)::p1) = (gcd_int c (uv_content2(p1))); + +(*. converts a uv-polynomial from mv-representation to uv-representation .*) +fun uv_to_list ([]:mv_poly)=[]:uv_poly + | uv_to_list ((c1,e1)::others) = + let + val count=ref 0; + val max=mv_grad((c1,e1)::others); + val help=ref ((c1,e1)::others); + val list=ref []; + in + if length(e1)>1 then raise error ("RATIONALS_TO_LIST_EXCEPTION: not univariate") + else if length(e1)=0 then [c1] + else + ( + count:=0; + while (!count)<=max do + ( + if length(!help)>0 andalso hd(#2(hd(!help)))=max-(!count) then + ( + list:=(#1(hd(!help)))::(!list); + help:=tl(!help) + ) + else + ( + list:= 0::(!list) + ); + count := (!count) + 1 + ); + (!list) + ) + end; + +(*. converts a uv-polynomial from uv-representation to mv-representation .*) +fun uv_to_poly ([]:uv_poly) = []:mv_poly + | uv_to_poly p1 = + let + val count=ref 0; + val help=ref p1; + val list=ref []; + in + while length(!help)>0 do + ( + if hd(!help)=0 then () + else list:=(hd(!help),[!count])::(!list); + count:=(!count)+1; + help:=tl(!help) + ); + (!list) + end; + +(*. univariate gcd calculation from polynomials in multivariate representation .*) +fun uv_gcd ([]:mv_poly) p2 = p2 + | uv_gcd p1 ([]:mv_poly) = p1 + | uv_gcd p1 [(c,[e])] = + let + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_)))); + val min=uv_mod_min(e,(hd(#2(hd(rev(!list)))))); + in + [(gcd_int (uv_content2(p1)) c,[min])] + end + | uv_gcd [(c,[e])] p2 = + let + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p2,LEX_)))); + val min=uv_mod_min(e,(hd(#2(hd(rev(!list)))))); + in + [(gcd_int (uv_content2(p2)) c,[min])] + end + | uv_gcd p11 p22 = uv_to_poly(uv_mod_gcd (uv_to_list(mv_shorten(p11,LEX_))) (uv_to_list(mv_shorten(p22,LEX_)))); + +(*. help function for the newton interpolation .*) +fun mv_newton_help ([]:mv_poly list,k:int) = []:mv_poly list + | mv_newton_help (pl:mv_poly list,k) = + let + val x=ref (rev(pl)); + val t=ref []; + val y=ref []; + val n=ref 1; + val n1=ref[]; + in + ( + while length(!x)>1 do + ( + if length(hd(!x))>0 then n1:=mv_null2(#2(hd(hd(!x)))) + else if length(hd(tl(!x)))>0 then n1:=mv_null2(#2(hd(hd(tl(!x))))) + else n1:=[]; + t:= #1(mv_division(mv_add(hd(!x),mv_skalar_mul(hd(tl(!x)),~1),LEX_),[(k,!n1)],LEX_)); + y:=(!t)::(!y); + x:=tl(!x) + ); + (!y) + ) + end; + +(*. help function for the newton interpolation .*) +fun mv_newton_add ([]:mv_poly list) t = []:mv_poly + | mv_newton_add [x:mv_poly] t = x + | mv_newton_add (pl:mv_poly list) t = + let + val expos=ref []; + val pll=ref pl; + in + ( + + while length(!pll)>0 andalso hd(!pll)=[] do + ( + pll:=tl(!pll) + ); + if length(!pll)>0 then expos:= #2(hd(hd(!pll))) else expos:=[]; + mv_add(hd(pl), + mv_mul( + mv_add(mv_correct(mv_cut([(1,mv_null2(!expos))]),1),[(~t,mv_null2(!expos))],LEX_), + mv_newton_add (tl(pl)) (t+1), + LEX_ + ), + LEX_) + ) + end; + +(*. calculates the newton interpolation with polynomial coefficients .*) +(*. step-depth is 1 and if the result is not an integerpolynomial .*) +(*. this function returns [] .*) +fun mv_newton ([]:(mv_poly) list) = []:mv_poly + | mv_newton ([mp]:(mv_poly) list) = mp:mv_poly + | mv_newton pl = + let + val c=ref pl; + val c1=ref []; + val n=length(pl); + val k=ref 1; + val i=ref n; + val ppl=ref []; + in + c1:=hd(pl)::[]; + c:=mv_newton_help(!c,!k); + c1:=(hd(!c))::(!c1); + while(length(!c)>1 andalso !k0 andalso hd(!c)=[] do c:=tl(!c); + if !c=[] then () else c:=mv_newton_help(!c,!k); + ppl:= !c; + if !c=[] then () else c1:=(hd(!c))::(!c1) + ); + while hd(!c1)=[] do c1:=tl(!c1); + c1:=rev(!c1); + ppl:= !c1; + mv_newton_add (!c1) 1 + end; + +(*. sets the exponents of the first variable to zero .*) +fun mv_null3([]:mv_poly) = []:mv_poly + | mv_null3((x,y)::xs) = (x,0::tl(y))::mv_null3(xs); + +(*. calculates the minimum exponents of a multivariate polynomial .*) +fun mv_min_pp([]:mv_poly)=[] + | mv_min_pp((c,e)::xs)= + let + val y=ref xs; + val x=ref []; + in + ( + x:=e; + while length(!y)>0 do + ( + x:=(map uv_mod_min) ((!x) ~~ (#2(hd(!y)))); + y:=tl(!y) + ); + !x + ) + end; + +(*. checks if all elements of the list have value zero .*) +fun list_is_null [] = true + | list_is_null (x::xs) = (x=0 andalso list_is_null(xs)); + +(* check if main variable is zero*) +fun main_zero (ms : mv_poly) = (list_is_null o (map (hd o #2))) ms; + +(*. calculates the content of an polynomial .*) +fun mv_content([]:mv_poly) = []:mv_poly + | mv_content(p1) = + let + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_)))); + val test=ref (hd(#2(hd(!list)))); + val result=ref []; + val min=(hd(#2(hd(rev(!list))))); + in + ( + if length(!list)>1 then + ( + while (if length(!list)>0 then (hd(#2(hd(!list)))=(!test)) else false) do + ( + result:=(#1(hd(!list)),tl(#2(hd(!list))))::(!result); + + if length(!list)<1 then list:=[] + else list:=tl(!list) + + ); + if length(!list)>0 then + ( + list:=mv_gcd (!result) (mv_cut(mv_content(!list))) + ) + else list:=(!result); + list:=mv_correct(!list,0); + (!list) + ) + else + ( + mv_null3(!list) + ) + ) + end + +(*. calculates the primitiv part of a polynomial .*) +and mv_pp([]:mv_poly) = []:mv_poly + | mv_pp(p1) = let + val cont=ref []; + val pp=ref[]; + in + cont:=mv_content(p1); + pp:=(#1(mv_division(p1,!cont,LEX_))); + if !pp=[] + then raise error("RATIONALS_MV_PP_EXCEPTION: Invalid Content ") + else (!pp) + end + +(*. calculates the gcd of two multivariate polynomials with a modular approach .*) +and mv_gcd ([]:mv_poly) ([]:mv_poly) :mv_poly= []:mv_poly + | mv_gcd ([]:mv_poly) (p2) :mv_poly= p2:mv_poly + | mv_gcd (p1:mv_poly) ([]) :mv_poly= p1:mv_poly + | mv_gcd ([(x,xs)]:mv_poly) ([(y,ys)]):mv_poly = + let + val xpoly:mv_poly = [(x,xs)]; + val ypoly:mv_poly = [(y,ys)]; + in + ( + if xs=ys then [((gcd_int x y),xs)] + else [((gcd_int x y),(map uv_mod_min)(xs~~ys))]:mv_poly + ) + end + | mv_gcd (p1:mv_poly) ([(y,ys)]) :mv_poly= + ( + [(gcd_int (uv_content2(p1)) (y),(map uv_mod_min)(mv_min_pp(p1)~~ys))]:mv_poly + ) + | mv_gcd ([(y,ys)]:mv_poly) (p2):mv_poly = + ( + [(gcd_int (uv_content2(p2)) (y),(map uv_mod_min)(mv_min_pp(p2)~~ys))]:mv_poly + ) + | mv_gcd (p1':mv_poly) (p2':mv_poly):mv_poly= + let + val vc=length(#2(hd(p1'))); + val cont = + ( + if main_zero(mv_content(p1')) andalso + (main_zero(mv_content(p2'))) then + mv_correct((mv_gcd (mv_cut(mv_content(p1'))) (mv_cut(mv_content(p2')))),0) + else + mv_gcd (mv_content(p1')) (mv_content(p2')) + ); + val p1= #1(mv_division(p1',mv_content(p1'),LEX_)); + val p2= #1(mv_division(p2',mv_content(p2'),LEX_)); + val gcd=ref []; + val candidate=ref []; + val interpolation_list=ref []; + val delta=ref []; + val p1r = ref []; + val p2r = ref []; + val p1r' = ref []; + val p2r' = ref []; + val factor=ref []; + val r=ref 0; + val gcd_r=ref []; + val d=ref 0; + val exit=ref 0; + val current_degree=ref 99999; (*. FIXME: unlimited ! .*) + in + ( + if vc<2 then (* areUnivariate(p1',p2') *) + ( + gcd:=uv_gcd (mv_shorten(p1',LEX_)) (mv_shorten(p2',LEX_)) + ) + else + ( + while !exit=0 do + ( + r:=(!r)+1; + p1r := mv_lc(p1,LEX_); + p2r := mv_lc(p2,LEX_); + if main_zero(!p1r) andalso + main_zero(!p2r) + then + ( + delta := mv_correct((mv_gcd (mv_cut (!p1r)) (mv_cut (!p2r))),0) + ) + else + ( + delta := mv_gcd (!p1r) (!p2r) + ); + (*if mv_shorten(mv_subs(!p1r,!r),LEX_)=[] andalso + mv_shorten(mv_subs(!p2r,!r),LEX_)=[] *) + if mv_lc2(mv_shorten(mv_subs(!p1r,!r),LEX_),LEX_)=0 andalso + mv_lc2(mv_shorten(mv_subs(!p2r,!r),LEX_),LEX_)=0 + then + ( + ) + else + ( + gcd_r:=mv_shorten(mv_gcd (mv_shorten(mv_subs(p1,!r),LEX_)) + (mv_shorten(mv_subs(p2,!r),LEX_)) ,LEX_); + gcd_r:= #1(mv_division(mv_mul(mv_correct(mv_subs(!delta,!r),0),!gcd_r,LEX_), + mv_correct(mv_lc(!gcd_r,LEX_),0),LEX_)); + d:=mv_deg2(!gcd_r); (* deg(gcd_r,z) *) + if (!d < !current_degree) then + ( + current_degree:= !d; + interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list) + ) + else + ( + if (!d = !current_degree) then + ( + interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list) + ) + else () + ) + ); + if length(!interpolation_list)> uv_mod_min(mv_deg(p1),mv_deg(p2)) then + ( + candidate := mv_newton(rev(!interpolation_list)); + if !candidate=[] then () + else + ( + candidate:=mv_pp(!candidate); + if mv_divides(!candidate,p1) andalso mv_divides(!candidate,p2) then + ( + gcd:= mv_mul(!candidate,cont,LEX_); + exit:=1 + ) + else () + ); + interpolation_list:=[mv_correct(!gcd_r,0)] + ) + else () + ) + ); + (!gcd):mv_poly + ) + end; + + +(*. calculates the least common divisor of two polynomials .*) +fun mv_lcm (p1:mv_poly) (p2:mv_poly) :mv_poly = + ( + #1(mv_division(mv_mul(p1,p2,LEX_),mv_gcd p1 p2,LEX_)) + ); + +(*. gets the variables (strings) of a term .*) +fun get_vars(term1) = (map free2str) (vars term1); (*["a","b","c"]; *) + +(*. counts the negative coefficents in a polynomial .*) +fun count_neg ([]:mv_poly) = 0 + | count_neg ((c,e)::xs) = if c<0 then 1+count_neg xs + else count_neg xs; + +(*. help function for is_polynomial + checks the order of the operators .*) +fun test_polynomial (Const ("uminus",_) $ Free (str,_)) _ = true (*WN.13.3.03*) + | test_polynomial (t as Free(str,_)) v = true + | test_polynomial (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false + else (test_polynomial t1 "*") andalso (test_polynomial t2 "*") + | test_polynomial (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false + else (test_polynomial t1 " ") andalso (test_polynomial t2 " ") + | test_polynomial (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_polynomial t1 "^") andalso (test_polynomial t2 "^") + | test_polynomial _ v = false; + +(*. tests if a term is a polynomial .*) +fun is_polynomial t = test_polynomial t " "; + +(*. help function for is_expanded + checks the order of the operators .*) +fun test_exp (t as Free(str,_)) v = true + | test_exp (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false + else (test_exp t1 "*") andalso (test_exp t2 "*") + | test_exp (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false + else (test_exp t1 " ") andalso (test_exp t2 " ") + | test_exp (t as Const ("op -",_) $ t1 $ t2) v = if v="*" orelse v="^" then false + else (test_exp t1 " ") andalso (test_exp t2 " ") + | test_exp (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_exp t1 "^") andalso (test_exp t2 "^") + | test_exp _ v = false; + + +(*. help function for check_coeff: + converts the term to a list of coefficients .*) +fun term2coef' (t as Free(str,_(*typ*))) v :mv_poly option = + let + val x=ref NONE; + val len=ref 0; + val vl=ref []; + val vh=ref []; + val i=ref 0; + in + if is_numeral str then + ( + SOME [(((the o int_of_str) str),mv_null2(v))] handle _ => NONE + ) + else (* variable *) + ( + len:=length(v); + vh:=v; + while ((!len)>(!i)) do + ( + if str=hd((!vh)) then + ( + vl:=1::(!vl) + ) + else + ( + vl:=0::(!vl) + ); + vh:=tl(!vh); + i:=(!i)+1 + ); + SOME [(1,rev(!vl))] handle _ => NONE + ) + end + | term2coef' (Const ("op *",_) $ t1 $ t2) v :mv_poly option= + let + val t1pp=ref []; + val t2pp=ref []; + val t1c=ref 0; + val t2c=ref 0; + in + ( + t1pp:=(#2(hd(the(term2coef' t1 v)))); + t2pp:=(#2(hd(the(term2coef' t2 v)))); + t1c:=(#1(hd(the(term2coef' t1 v)))); + t2c:=(#1(hd(the(term2coef' t2 v)))); + + SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] handle _ => NONE + + ) + end + | term2coef' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ (t2 as Free (str2,_))) v :mv_poly option= + let + val x=ref NONE; + val len=ref 0; + val vl=ref []; + val vh=ref []; + val vtemp=ref []; + val i=ref 0; + in + ( + if (not o is_numeral) str1 andalso is_numeral str2 then + ( + len:=length(v); + vh:=v; + + while ((!len)>(!i)) do + ( + if str1=hd((!vh)) then + ( + vl:=((the o int_of_str) str2)::(!vl) + ) + else + ( + vl:=0::(!vl) + ); + vh:=tl(!vh); + i:=(!i)+1 + ); + SOME [(1,rev(!vl))] handle _ => NONE + ) + else raise error ("RATIONALS_TERM2COEF_EXCEPTION 1: Invalid term") + ) + end + | term2coef' (Const ("op +",_) $ t1 $ t2) v :mv_poly option= + ( + SOME ((the(term2coef' t1 v)) @ (the(term2coef' t2 v))) handle _ => NONE + ) + | term2coef' (Const ("op -",_) $ t1 $ t2) v :mv_poly option= + ( + SOME ((the(term2coef' t1 v)) @ mv_skalar_mul((the(term2coef' t2 v)),1)) handle _ => NONE + ) + | term2coef' (term) v = raise error ("RATIONALS_TERM2COEF_EXCEPTION 2: Invalid term"); + +(*. checks if all coefficients of a polynomial are positiv (except the first) .*) +fun check_coeff t = (* erste Koeffizient kann <0 sein !!! *) + if count_neg(tl(the(term2coef' t (get_vars(t)))))=0 then true + else false; + +(*. checks for expanded term [3] .*) +fun is_expanded t = test_exp t " " andalso check_coeff(t); + +(*WN.7.3.03 Hilfsfunktion f"ur term2poly'*) +fun mk_monom v' p vs = + let fun conv p (v: string) = if v'= v then p else 0 + in map (conv p) vs end; +(* mk_monom "y" 5 ["a","b","x","y","z"]; +val it = [0,0,0,5,0] : int list*) + +(*. this function converts the term representation into the internal representation mv_poly .*) +fun term2poly' (Const ("uminus",_) $ Free (str,_)) v = (*WN.7.3.03*) + if is_numeral str + then SOME [((the o int_of_str) ("-"^str), mk_monom "#" 0 v)] + else SOME [(~1, mk_monom str 1 v)] + + | term2poly' (Free(str,_)) v :mv_poly option = + let + val x=ref NONE; + val len=ref 0; + val vl=ref []; + val vh=ref []; + val i=ref 0; + in + if is_numeral str then + ( + SOME [(((the o int_of_str) str),mv_null2 v)] handle _ => NONE + ) + else (* variable *) + ( + len:=length v; + vh:= v; + while ((!len)>(!i)) do + ( + if str=hd((!vh)) then + ( + vl:=1::(!vl) + ) + else + ( + vl:=0::(!vl) + ); + vh:=tl(!vh); + i:=(!i)+1 + ); + SOME [(1,rev(!vl))] handle _ => NONE + ) + end + | term2poly' (Const ("op *",_) $ t1 $ t2) v :mv_poly option= + let + val t1pp=ref []; + val t2pp=ref []; + val t1c=ref 0; + val t2c=ref 0; + in + ( + t1pp:=(#2(hd(the(term2poly' t1 v)))); + t2pp:=(#2(hd(the(term2poly' t2 v)))); + t1c:=(#1(hd(the(term2poly' t1 v)))); + t2c:=(#1(hd(the(term2poly' t2 v)))); + + SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] + handle _ => NONE + + ) + end + | term2poly' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ + (t2 as Free (str2,_))) v :mv_poly option= + let + val x=ref NONE; + val len=ref 0; + val vl=ref []; + val vh=ref []; + val vtemp=ref []; + val i=ref 0; + in + ( + if (not o is_numeral) str1 andalso is_numeral str2 then + ( + len:=length(v); + vh:=v; + + while ((!len)>(!i)) do + ( + if str1=hd((!vh)) then + ( + vl:=((the o int_of_str) str2)::(!vl) + ) + else + ( + vl:=0::(!vl) + ); + vh:=tl(!vh); + i:=(!i)+1 + ); + SOME [(1,rev(!vl))] handle _ => NONE + ) + else raise error ("RATIONALS_TERM2POLY_EXCEPTION 1: Invalid term") + ) + end + | term2poly' (Const ("op +",_) $ t1 $ t2) v :mv_poly option = + ( + SOME ((the(term2poly' t1 v)) @ (the(term2poly' t2 v))) handle _ => NONE + ) + | term2poly' (Const ("op -",_) $ t1 $ t2) v :mv_poly option = + ( + SOME ((the(term2poly' t1 v)) @ mv_skalar_mul((the(term2poly' t2 v)),~1)) handle _ => NONE + ) + | term2poly' (term) v = raise error ("RATIONALS_TERM2POLY_EXCEPTION 2: Invalid term"); + +(*. translates an Isabelle term into internal representation. + term2poly + fn : term -> (*normalform [2] *) + string list -> (*for ...!!! BITTE DIE ERKLÄRUNG, + DIE DU MIR LETZTES MAL GEGEBEN HAST*) + mv_monom list (*internal representation *) + option (*the translation may fail with NONE*) +.*) +fun term2poly (t:term) v = + if is_polynomial t then term2poly' t v + else raise error ("term2poly: invalid = "^(term2str t)); + +(*. same as term2poly with automatic detection of the variables .*) +fun term2polyx t = term2poly t (((map free2str) o vars) t); + +(*. checks if the term is in expanded polynomial form and converts it into the internal representation .*) +fun expanded2poly (t:term) v = + (*if is_expanded t then*) term2poly' t v + (*else raise error ("RATIONALS_EXPANDED2POLY_EXCEPTION: Invalid Polynomial")*); + +(*. same as expanded2poly with automatic detection of the variables .*) +fun expanded2polyx t = expanded2poly t (((map free2str) o vars) t); + +(*. converts a powerproduct into term representation .*) +fun powerproduct2term(xs,v) = + let + val xss=ref xs; + val vv=ref v; + in + ( + while hd(!xss)=0 do + ( + xss:=tl(!xss); + vv:=tl(!vv) + ); + + if list_is_null(tl(!xss)) then + ( + if hd(!xss)=1 then Free(hd(!vv), HOLogic.realT) + else + ( + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT) + ) + ) + else + ( + if hd(!xss)=1 then + ( + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + Free(hd(!vv), HOLogic.realT) $ + powerproduct2term(tl(!xss),tl(!vv)) + ) + else + ( + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + ( + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT) + ) $ + powerproduct2term(tl(!xss),tl(!vv)) + ) + ) + ) + end; + +(*. converts a monom into term representation .*) +(*fun monom2term ((c,e):mv_monom, v:string list) = + if c=0 then Free(str_of_int 0,HOLogic.realT) + else + ( + if list_is_null(e) then + ( + Free(str_of_int c,HOLogic.realT) + ) + else + ( + if c=1 then + ( + powerproduct2term(e,v) + ) + else + ( + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + Free(str_of_int c,HOLogic.realT) $ + powerproduct2term(e,v) + ) + ) + );*) + + +(*fun monom2term ((i, is):mv_monom, v) = + if list_is_null is + then + if i >= 0 + then Free (str_of_int i, HOLogic.realT) + else Const ("uminus", HOLogic.realT --> HOLogic.realT) $ + Free ((str_of_int o abs) i, HOLogic.realT) + else + if i > 0 + then Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $ + (Free (str_of_int i, HOLogic.realT)) $ + powerproduct2term(is, v) + else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $ + (Const ("uminus", HOLogic.realT --> HOLogic.realT) $ + Free ((str_of_int o abs) i, HOLogic.realT)) $ + powerproduct2term(is, vs);---------------------------*) +fun monom2term ((i, is) : mv_monom, vs) = + if list_is_null is + then Free (str_of_int i, HOLogic.realT) + else if i = 1 + then powerproduct2term (is, vs) + else Const ("op *", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $ + (Free (str_of_int i, HOLogic.realT)) $ + powerproduct2term (is, vs); + +(*. converts the internal polynomial representation into an Isabelle term.*) +fun poly2term' ([] : mv_poly, vs) = Free(str_of_int 0, HOLogic.realT) + | poly2term' ([(c, e) : mv_monom], vs) = monom2term ((c, e), vs) + | poly2term' ((c, e) :: ces, vs) = + Const("op +", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $ + poly2term (ces, vs) $ monom2term ((c, e), vs) +and poly2term (xs, vs) = poly2term' (rev (sort (mv_geq LEX_) (xs)), vs); + + +(*. converts a monom into term representation .*) +(*. ignores the sign of the coefficients => use only for exp-poly functions .*) +fun monom2term2((c,e):mv_monom, v:string list) = + if c=0 then Free(str_of_int 0,HOLogic.realT) + else + ( + if list_is_null(e) then + ( + Free(str_of_int (abs(c)),HOLogic.realT) + ) + else + ( + if abs(c)=1 then + ( + powerproduct2term(e,v) + ) + else + ( + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + Free(str_of_int (abs(c)),HOLogic.realT) $ + powerproduct2term(e,v) + ) + ) + ); + +(*. converts the expanded polynomial representation into the term representation .*) +fun exp2term' ([]:mv_poly,vars) = Free(str_of_int 0,HOLogic.realT) + | exp2term' ([(c,e)],vars) = monom2term((c,e),vars) + | exp2term' ((c1,e1)::others,vars) = + if c1<0 then + Const("op -",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + exp2term'(others,vars) $ + ( + monom2term2((c1,e1),vars) + ) + else + Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + exp2term'(others,vars) $ + ( + monom2term2((c1,e1),vars) + ); + +(*. sorts the powerproduct by lexicographic termorder and converts them into + a term in polynomial representation .*) +fun poly2expanded (xs,vars) = exp2term'(rev(sort (mv_geq LEX_) (xs)),vars); + +(*. converts a polynomial into expanded form .*) +fun polynomial2expanded t = + (let + val vars=(((map free2str) o vars) t); + in + SOME (poly2expanded (the (term2poly t vars), vars)) + end) handle _ => NONE; + +(*. converts a polynomial into polynomial form .*) +fun expanded2polynomial t = + (let + val vars=(((map free2str) o vars) t); + in + SOME (poly2term (the (expanded2poly t vars), vars)) + end) handle _ => NONE; + + +(*. calculates the greatest common divisor of numerator and denominator and seperates it from each .*) +fun step_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) = + let + val p1' = ref []; + val p2' = ref []; + val p3 = ref [] + val vars = rev(get_vars(p1) union get_vars(p2)); + in + ( + p1':= sort (mv_geq LEX_) (the (term2poly p1 vars )); + p2':= sort (mv_geq LEX_) (the (term2poly p2 vars )); + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); + if (!p3)=[(1,mv_null2(vars))] then + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2 + ) + else + ( + + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); + + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(!p1',vars) $ + poly2term(!p3,vars) + ) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(!p2',vars) $ + poly2term(!p3,vars) + ) + ) + else + ( + p1':=mv_skalar_mul(!p1',~1); + p2':=mv_skalar_mul(!p2',~1); + p3:=mv_skalar_mul(!p3,~1); + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(!p1',vars) $ + poly2term(!p3,vars) + ) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(!p2',vars) $ + poly2term(!p3,vars) + ) + ) + ) + ) + ) + end +| step_cancel _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction"); + + +(*. same as step_cancel, this time for expanded forms (input+output) .*) +fun step_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) = + let + val p1' = ref []; + val p2' = ref []; + val p3 = ref [] + val vars = rev(get_vars(p1) union get_vars(p2)); + in + ( + p1':= sort (mv_geq LEX_) (the (expanded2poly p1 vars )); + p2':= sort (mv_geq LEX_) (the (expanded2poly p2 vars )); + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); + if (!p3)=[(1,mv_null2(vars))] then + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2 + ) + else + ( + + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); + + if #1(hd(sort (mv_geq LEX_) (!p2')))(* mv_lc2(!p2',LEX_)*)>0 then + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(!p1',vars) $ + poly2expanded(!p3,vars) + ) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(!p2',vars) $ + poly2expanded(!p3,vars) + ) + ) + else + ( + p1':=mv_skalar_mul(!p1',~1); + p2':=mv_skalar_mul(!p2',~1); + p3:=mv_skalar_mul(!p3,~1); + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(!p1',vars) $ + poly2expanded(!p3,vars) + ) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(!p2',vars) $ + poly2expanded(!p3,vars) + ) + ) + ) + ) + ) + end +| step_cancel_expanded _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction"); + +(*. calculates the greatest common divisor of numerator and denominator and divides each through it .*) +fun direct_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) = + let + val p1' = ref []; + val p2' = ref []; + val p3 = ref [] + val vars = rev(get_vars(p1) union get_vars(p2)); + in + ( + p1':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p1 vars )),LEX_)); + p2':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p2 vars )),LEX_)); + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); + + if (!p3)=[(1,mv_null2(vars))] then + ( + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[]) + ) + else + ( + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then + ( + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2term((!p1'),vars) + ) + $ + ( + poly2term((!p2'),vars) + ) + ) + , + if mv_grad(!p3)>0 then + [ + ( + Const ("Not",[bool]--->bool) $ + ( + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ + poly2term((!p3),vars) $ + Free("0",HOLogic.realT) + ) + ) + ] + else + [] + ) + else + ( + p1':=mv_skalar_mul(!p1',~1); + p2':=mv_skalar_mul(!p2',~1); + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1); + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2term((!p1'),vars) + ) + $ + ( + poly2term((!p2'),vars) + ) + , + if mv_grad(!p3)>0 then + [ + ( + Const ("Not",[bool]--->bool) $ + ( + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ + poly2term((!p3),vars) $ + Free("0",HOLogic.realT) + ) + ) + ] + else + [] + ) + ) + ) + ) + end + | direct_cancel _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction"); + +(*. same es direct_cancel, this time for expanded forms (input+output).*) +fun direct_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) = + let + val p1' = ref []; + val p2' = ref []; + val p3 = ref [] + val vars = rev(get_vars(p1) union get_vars(p2)); + in + ( + p1':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p1 vars )),LEX_)); + p2':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p2 vars )),LEX_)); + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2')); + + if (!p3)=[(1,mv_null2(vars))] then + ( + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[]) + ) + else + ( + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_))); + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_))); + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then + ( + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2expanded((!p1'),vars) + ) + $ + ( + poly2expanded((!p2'),vars) + ) + ) + , + if mv_grad(!p3)>0 then + [ + ( + Const ("Not",[bool]--->bool) $ + ( + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ + poly2expanded((!p3),vars) $ + Free("0",HOLogic.realT) + ) + ) + ] + else + [] + ) + else + ( + p1':=mv_skalar_mul(!p1',~1); + p2':=mv_skalar_mul(!p2',~1); + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1); + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2expanded((!p1'),vars) + ) + $ + ( + poly2expanded((!p2'),vars) + ) + , + if mv_grad(!p3)>0 then + [ + ( + Const ("Not",[bool]--->bool) $ + ( + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $ + poly2expanded((!p3),vars) $ + Free("0",HOLogic.realT) + ) + ) + ] + else + [] + ) + ) + ) + ) + end + | direct_cancel_expanded _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction"); + + +(*. adds two fractions .*) +fun add_fract ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) = + let + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22); + val t11'=ref (the(term2poly t11 vars)); +val _= writeln"### add_fract: done t11" + val t12'=ref (the(term2poly t12 vars)); +val _= writeln"### add_fract: done t12" + val t21'=ref (the(term2poly t21 vars)); +val _= writeln"### add_fract: done t21" + val t22'=ref (the(term2poly t22 vars)); +val _= writeln"### add_fract: done t22" + val den=ref []; + val nom=ref []; + val m1=ref []; + val m2=ref []; + in + + ( + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22')); +writeln"### add_fract: done sort mv_lcm"; + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_))); +writeln"### add_fract: done sort mv_division t12"; + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_))); +writeln"### add_fract: done sort mv_division t22"; + nom :=sort (mv_geq LEX_) + (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_), + mv_mul(!t21',!m2,LEX_), + LEX_), + LEX_)); +writeln"### add_fract: done sort mv_add"; + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2term((!nom),vars) + ) + $ + ( + poly2term((!den),vars) + ) + ) + ) + end + | add_fract (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: Invalid add_fraction call"); + +(*. adds two expanded fractions .*) +fun add_fract_exp ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) = + let + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22); + val t11'=ref (the(expanded2poly t11 vars)); + val t12'=ref (the(expanded2poly t12 vars)); + val t21'=ref (the(expanded2poly t21 vars)); + val t22'=ref (the(expanded2poly t22 vars)); + val den=ref []; + val nom=ref []; + val m1=ref []; + val m2=ref []; + in + + ( + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22')); + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_))); + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_))); + nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_)); + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + poly2expanded((!nom),vars) + ) + $ + ( + poly2expanded((!den),vars) + ) + ) + ) + end + | add_fract_exp (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXP_EXCEPTION: Invalid add_fraction call"); + +(*. adds a list of terms .*) +fun add_list_of_fractions []= (Free("0",HOLogic.realT),[]) + | add_list_of_fractions [x]= direct_cancel x + | add_list_of_fractions (x::y::xs) = + let + val (t1a,rest1)=direct_cancel(x); +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(x)"; + val (t2a,rest2)=direct_cancel(y); +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(y)"; + val (t3a,rest3)=(add_list_of_fractions (add_fract(t1a,t2a)::xs)); +val _= writeln"### add_list_of_fractions xs: has done add_list_of_fraction xs"; + val (t4a,rest4)=direct_cancel(t3a); +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(t3a)"; + val rest=rest1 union rest2 union rest3 union rest4; + in + (writeln"### add_list_of_fractions in"; + ( + (t4a,rest) + ) + ) + end; + +(*. adds a list of expanded terms .*) +fun add_list_of_fractions_exp []= (Free("0",HOLogic.realT),[]) + | add_list_of_fractions_exp [x]= direct_cancel_expanded x + | add_list_of_fractions_exp (x::y::xs) = + let + val (t1a,rest1)=direct_cancel_expanded(x); + val (t2a,rest2)=direct_cancel_expanded(y); + val (t3a,rest3)=(add_list_of_fractions_exp (add_fract_exp(t1a,t2a)::xs)); + val (t4a,rest4)=direct_cancel_expanded(t3a); + val rest=rest1 union rest2 union rest3 union rest4; + in + ( + (t4a,rest) + ) + end; + +(*. calculates the lcm of a list of mv_poly .*) +fun calc_lcm ([x],var)= (x,var) + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var); + +(*. converts a list of terms to a list of mv_poly .*) +fun t2d([],_)=[] + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars); + +(*. same as t2d, this time for expanded forms .*) +fun t2d_exp([],_)=[] + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars); + +(*. converts a list of fract terms to a list of their denominators .*) +fun termlist2denominators [] = ([],[]) + | termlist2denominators xs = + let + val xxs=ref xs; + val var=ref []; + in + var:=[]; + while length(!xxs)>0 do + ( + let + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); + in + ( + xxs:=tl(!xxs); + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) + ) + end + ); + (t2d(xs,!var),!var) + end; + +(*. calculates the lcm of a list of mv_poly .*) +fun calc_lcm ([x],var)= (x,var) + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var); + +(*. converts a list of terms to a list of mv_poly .*) +fun t2d([],_)=[] + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars); + +(*. same as t2d, this time for expanded forms .*) +fun t2d_exp([],_)=[] + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars); + +(*. converts a list of fract terms to a list of their denominators .*) +fun termlist2denominators [] = ([],[]) + | termlist2denominators xs = + let + val xxs=ref xs; + val var=ref []; + in + var:=[]; + while length(!xxs)>0 do + ( + let + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); + in + ( + xxs:=tl(!xxs); + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) + ) + end + ); + (t2d(xs,!var),!var) + end; + +(*. same as termlist2denminators, this time for expanded forms .*) +fun termlist2denominators_exp [] = ([],[]) + | termlist2denominators_exp xs = + let + val xxs=ref xs; + val var=ref []; + in + var:=[]; + while length(!xxs)>0 do + ( + let + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs); + in + ( + xxs:=tl(!xxs); + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var)) + ) + end + ); + (t2d_exp(xs,!var),!var) + end; + +(*. reduces all fractions to the least common denominator .*) +fun com_den(x::xs,denom,den,var)= + let + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; + val p2= sort (mv_geq LEX_) (the(term2poly p2' var)); + val p3= #1(mv_division(denom,p2,LEX_)); + val p1var=get_vars(p1'); + in + if length(xs)>0 then + if p3=[(1,mv_null2(var))] then + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + poly2term(the (term2poly p1' p1var),p1var) + $ + den + ) + $ + #1(com_den(xs,denom,den,var)) + , + [] + ) + else + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(the (term2poly p1' p1var),p1var) $ + poly2term(p3,var) + ) + $ + ( + den + ) + ) + $ + #1(com_den(xs,denom,den,var)) + , + [] + ) + else + if p3=[(1,mv_null2(var))] then + ( + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + poly2term(the (term2poly p1' p1var),p1var) + $ + den + ) + , + [] + ) + else + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(the (term2poly p1' p1var),p1var) $ + poly2term(p3,var) + ) + $ + den + , + [] + ) + end; + +(*. same as com_den, this time for expanded forms .*) +fun com_den_exp(x::xs,denom,den,var)= + let + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var)); + val p3= #1(mv_division(denom,p2,LEX_)); + val p1var=get_vars(p1'); + in + if length(xs)>0 then + if p3=[(1,mv_null2(var))] then + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + poly2expanded(the(expanded2poly p1' p1var),p1var) + $ + den + ) + $ + #1(com_den_exp(xs,denom,den,var)) + , + [] + ) + else + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(the(expanded2poly p1' p1var),p1var) $ + poly2expanded(p3,var) + ) + $ + ( + den + ) + ) + $ + #1(com_den_exp(xs,denom,den,var)) + , + [] + ) + else + if p3=[(1,mv_null2(var))] then + ( + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + poly2expanded(the(expanded2poly p1' p1var),p1var) + $ + den + ) + , + [] + ) + else + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) + $ + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(the(expanded2poly p1' p1var),p1var) $ + poly2expanded(p3,var) + ) + $ + den + , + [] + ) + end; + +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon +------------------------------------------------------------- +(* WN0210???SK brauch ma des überhaupt *) +fun com_den2(x::xs,denom,den,var)= + let + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; + val p2= sort (mv_geq LEX_) (the(term2poly p2' var)); + val p3= #1(mv_division(denom,p2,LEX_)); + val p1var=get_vars(p1'); + in + if length(xs)>0 then + if p3=[(1,mv_null2(var))] then + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(the(term2poly p1' p1var),p1var) $ + com_den2(xs,denom,den,var) + ) + else + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + ( + let + val p3'=poly2term(p3,var); + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); + in + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars) + end + ) $ + com_den2(xs,denom,den,var) + ) + else + if p3=[(1,mv_null2(var))] then + ( + poly2term(the(term2poly p1' p1var),p1var) + ) + else + ( + let + val p3'=poly2term(p3,var); + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); + in + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars) + end + ) + end; + +(* WN0210???SK brauch ma des überhaupt *) +fun com_den_exp2(x::xs,denom,den,var)= + let + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x; + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var)); + val p3= #1(mv_division(denom,p2,LEX_)); + val p1var=get_vars p1'; + in + if length(xs)>0 then + if p3=[(1,mv_null2(var))] then + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(the (expanded2poly p1' p1var),p1var) $ + com_den_exp2(xs,denom,den,var) + ) + else + ( + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + ( + let + val p3'=poly2expanded(p3,var); + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); + in + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars) + end + ) $ + com_den_exp2(xs,denom,den,var) + ) + else + if p3=[(1,mv_null2(var))] then + ( + poly2expanded(the (expanded2poly p1' p1var),p1var) + ) + else + ( + let + val p3'=poly2expanded(p3,var); + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3'); + in + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars) + end + ) + end; +---------------------------------------------------------*) + + +(*. searches for an element y of a list ys, which has an gcd not 1 with x .*) +fun exists_gcd (x,[]) = false + | exists_gcd (x,y::ys) = if mv_gcd x y = [(1,mv_null2(#2(hd(x))))] then exists_gcd (x,ys) + else true; + +(*. divides each element of the list xs with y .*) +fun list_div ([],y) = [] + | list_div (x::xs,y) = + let + val (d,r)=mv_division(x,y,LEX_); + in + if r=[] then + d::list_div(xs,y) + else x::list_div(xs,y) + end; + +(*. checks if x is in the list ys .*) +fun in_list (x,[]) = false + | in_list (x,y::ys) = if x=y then true + else in_list(x,ys); + +(*. deletes all equal elements of the list xs .*) +fun kill_equal [] = [] + | kill_equal (x::xs) = if in_list(x,xs) orelse x=[(1,mv_null2(#2(hd(x))))] then kill_equal(xs) + else x::kill_equal(xs); + +(*. searches for new factors .*) +fun new_factors [] = [] + | new_factors (list:mv_poly list):mv_poly list = + let + val l = kill_equal list; + val len = length(l); + in + if len>=2 then + ( + let + val x::y::xs=l; + val gcd=mv_gcd x y; + in + if gcd=[(1,mv_null2(#2(hd(x))))] then + ( + if exists_gcd(x,xs) then new_factors (y::xs @ [x]) + else x::new_factors(y::xs) + ) + else gcd::new_factors(kill_equal(list_div(x::y::xs,gcd))) + end + ) + else + if len=1 then [hd(l)] + else [] + end; + +(*. gets the factors of a list .*) +fun get_factors x = new_factors x; + +(*. multiplies the elements of the list .*) +fun multi_list [] = [] + | multi_list (x::xs) = if xs=[] then x + else mv_mul(x,multi_list xs,LEX_); + +(*. makes a term out of the elements of the list (polynomial representation) .*) +fun make_term ([],vars) = Free(str_of_int 0,HOLogic.realT) + | make_term ((x::xs),vars) = if length(xs)=0 then poly2term(sort (mv_geq LEX_) (x),vars) + else + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2term(sort (mv_geq LEX_) (x),vars) $ + make_term(xs,vars) + ); + +(*. factorizes the denominator (polynomial representation) .*) +fun factorize_den (l,den,vars) = + let + val factor_list=kill_equal( (get_factors l)); + val mlist=multi_list(factor_list); + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_); + in + if rest=[] then + ( + if last=[(1,mv_null2(vars))] then make_term(factor_list,vars) + else make_term(last::factor_list,vars) + ) + else raise error ("RATIONALS_FACTORIZE_DEN_EXCEPTION: Invalid factor by division") + end; + +(*. makes a term out of the elements of the list (expanded polynomial representation) .*) +fun make_exp ([],vars) = Free(str_of_int 0,HOLogic.realT) + | make_exp ((x::xs),vars) = if length(xs)=0 then poly2expanded(sort (mv_geq LEX_) (x),vars) + else + ( + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + poly2expanded(sort (mv_geq LEX_) (x),vars) $ + make_exp(xs,vars) + ); + +(*. factorizes the denominator (expanded polynomial representation) .*) +fun factorize_den_exp (l,den,vars) = + let + val factor_list=kill_equal( (get_factors l)); + val mlist=multi_list(factor_list); + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_); + in + if rest=[] then + ( + if last=[(1,mv_null2(vars))] then make_exp(factor_list,vars) + else make_exp(last::factor_list,vars) + ) + else raise error ("RATIONALS_FACTORIZE_DEN_EXP_EXCEPTION: Invalid factor by division") + end; + +(*. calculates the common denominator of all elements of the list and multiplies .*) +(*. the nominators and denominators with the correct factor .*) +(*. (polynomial representation) .*) +fun step_add_list_of_fractions []=(Free("0",HOLogic.realT),[]:term list) + | step_add_list_of_fractions [x]= raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXCEPTION: Nothing to add") + | step_add_list_of_fractions (xs) = + let + val den_list=termlist2denominators (xs); (* list of denominators *) + val (denom,var)=calc_lcm(den_list); (* common denominator *) + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) + in + com_den(xs,denom,den,var) + end; + +(*. calculates the common denominator of all elements of the list and multiplies .*) +(*. the nominators and denominators with the correct factor .*) +(*. (expanded polynomial representation) .*) +fun step_add_list_of_fractions_exp [] = (Free("0",HOLogic.realT),[]:term list) + | step_add_list_of_fractions_exp [x] = raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXP_EXCEPTION: Nothing to add") + | step_add_list_of_fractions_exp (xs)= + let + val den_list=termlist2denominators_exp (xs); (* list of denominators *) + val (denom,var)=calc_lcm(den_list); (* common denominator *) + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) + in + com_den_exp(xs,denom,den,var) + end; + +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon +------------------------------------------------------------- +(* WN0210???SK brauch ma des überhaupt *) +fun step_add_list_of_fractions2 []=(Free("0",HOLogic.realT),[]:term list) + | step_add_list_of_fractions2 [x]=(x,[]) + | step_add_list_of_fractions2 (xs) = + let + val den_list=termlist2denominators (xs); (* list of denominators *) + val (denom,var)=calc_lcm(den_list); (* common denominator *) + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) + in + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + com_den2(xs,denom, poly2term(denom,var)(*den*),var) $ + poly2term(denom,var) + , + [] + ) + end; + +(* WN0210???SK brauch ma des überhaupt *) +fun step_add_list_of_fractions2_exp []=(Free("0",HOLogic.realT),[]:term list) + | step_add_list_of_fractions2_exp [x]=(x,[]) + | step_add_list_of_fractions2_exp (xs) = + let + val den_list=termlist2denominators_exp (xs); (* list of denominators *) + val (denom,var)=calc_lcm(den_list); (* common denominator *) + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *) + in + ( + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + com_den_exp2(xs,denom, poly2term(denom,var)(*den*),var) $ + poly2expanded(denom,var) + , + [] + ) + end; +---------------------------------------------- *) + + +(*. converts a term, which contains severel terms seperated by +, into a list of these terms .*) +fun term2list (t as (Const("HOL.divide",_) $ _ $ _)) = [t] + | term2list (t as (Const("Atools.pow",_) $ _ $ _)) = + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + t $ Free("1",HOLogic.realT) + ] + | term2list (t as (Free(_,_))) = + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + t $ Free("1",HOLogic.realT) + ] + | term2list (t as (Const("op *",_) $ _ $ _)) = + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ + t $ Free("1",HOLogic.realT) + ] + | term2list (Const("op +",_) $ t1 $ t2) = term2list(t1) @ term2list(t2) + | term2list (Const("op -",_) $ t1 $ t2) = + raise error ("RATIONALS_TERM2LIST_EXCEPTION: - not implemented yet") + | term2list _ = raise error ("RATIONALS_TERM2LIST_EXCEPTION: invalid term"); + +(*.factors out the gcd of nominator and denominator: + a/b = (a' * gcd)/(b' * gcd), a,b,gcd are poly[2].*) +fun factout_p_ (thy:theory) t = SOME (step_cancel t,[]:term list); +fun factout_ (thy:theory) t = SOME (step_cancel_expanded t,[]:term list); + +(*.cancels a single fraction with normalform [2] + resulting in a canceled fraction [2], see factout_ .*) +fun cancel_p_ (thy:theory) t = (*WN.2.6.03 no rewrite -> NONE !*) + (let val (t',asm) = direct_cancel(*_expanded ... corrected MG.21.8.03*) t + in if t = t' then NONE else SOME (t',asm) + end) handle _ => NONE; +(*.the same as above with normalform [3] + val cancel_ : + theory -> (*10.02 unused *) + term -> (*fraction in normalform [3] *) + (term * (*fraction in normalform [3] *) + term list) (*casual asumptions in normalform [3] *) + option (*NONE: the function is not applicable *).*) +fun cancel_ (thy:theory) t = SOME (direct_cancel_expanded t) handle _ => NONE; + +(*.transforms sums of at least 2 fractions [3] to + sums with the least common multiple as nominator.*) +fun common_nominator_p_ (thy:theory) t = +((*writeln("### common_nominator_p_ called");*) + SOME (step_add_list_of_fractions(term2list(t))) handle _ => NONE +); +fun common_nominator_ (thy:theory) t = + SOME (step_add_list_of_fractions_exp(term2list(t))) handle _ => NONE; + +(*.add 2 or more fractions +val add_fraction_p_ : + theory -> (*10.02 unused *) + term -> (*2 or more fractions with normalform [2] *) + (term * (*one fraction with normalform [2] *) + term list) (*casual assumptions in normalform [2] WN0210???SK *) + option (*NONE: the function is not applicable *).*) +fun add_fraction_p_ (thy:theory) t = +(writeln("### add_fraction_p_ called"); + (let val ts = term2list t + in if 1 < length ts + then SOME (add_list_of_fractions ts) + else NONE (*raise error ("RATIONALS_ADD_EXCEPTION: nothing to add")*) + end) handle _ => NONE +); +(*.same as add_fraction_p_ but with normalform [3].*) +(*SOME (step_add_list_of_fractions2(term2list(t))); *) +fun add_fraction_ (thy:theory) t = + if length(term2list(t))>1 + then SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE + else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*) + NONE; +fun add_fraction_ (thy:theory) t = + (if 1 < length (term2list t) + then SOME (add_list_of_fractions_exp (term2list t)) + else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*) + NONE) handle _ => NONE; + +(*SOME (step_add_list_of_fractions2_exp(term2list(t))); *) + +(*. brings the term into a normal form .*) +fun norm_rational_ (thy:theory) t = + SOME (add_list_of_fractions(term2list(t))) handle _ => NONE; +fun norm_expanded_rat_ (thy:theory) t = + SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE; + + +(*.evaluates conditions in calculate_Rational.*) +(*make local with FIXX@ME result:term *term list*) +val calc_rat_erls = prep_rls( + Rls {id = "calc_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [], *) + rules = + [Calc ("op =",eval_equal "#equal_"), + Calc ("Atools.is'_const",eval_const "#is_const_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false) + ], + scr = EmptyScr}); + + +(*.simplifies expressions with numerals; + does NOT rearrange the term by AC-rewriting; thus terms with variables + need to have constants to be commuted together respectively.*) +val calculate_Rational = prep_rls( + merge_rls "calculate_Rational" + (Rls {id = "divide", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = calc_rat_erls, srls = Erls, (*asm_thm = [],*) + calc = [], + rules = + [Calc ("HOL.divide" ,eval_cancel "#divide_"), + + Thm ("sym_real_minus_divide_eq", + num_str (real_minus_divide_eq RS sym)), + (*SYM - ?x / ?y = - (?x / ?y) may come from subst*) + + Thm ("rat_add",num_str rat_add), + (*"[| a is_const; b is_const; c is_const; d is_const |] ==> \ + \"a / c + b / d = (a * d) / (c * d) + (b * c ) / (d * c)"*) + Thm ("rat_add1",num_str rat_add1), + (*"[| a is_const; b is_const; c is_const |] ==> \ + \"a / c + b / c = (a + b) / c"*) + Thm ("rat_add2",num_str rat_add2), + (*"[| ?a is_const; ?b is_const; ?c is_const |] ==> \ + \?a / ?c + ?b = (?a + ?b * ?c) / ?c"*) + Thm ("rat_add3",num_str rat_add3), + (*"[| a is_const; b is_const; c is_const |] ==> \ + \"a + b / c = (a * c) / c + b / c"\ + \.... is_const to be omitted here FIXME*) + + Thm ("rat_mult",num_str rat_mult), + (*a / b * (c / d) = a * c / (b * d)*) + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), + (*?x * (?y / ?z) = ?x * ?y / ?z*) + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), + (*?y / ?z * ?x = ?y * ?x / ?z*) + + Thm ("real_divide_divide1",num_str real_divide_divide1), + (*"?y ~= 0 ==> ?u / ?v / (?y / ?z) = ?u / ?v * (?z / ?y)"*) + Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq), + (*"?x / ?y / ?z = ?x / (?y * ?z)"*) + + Thm ("rat_power", num_str rat_power), + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) + + Thm ("mult_cross",num_str mult_cross), + (*"[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)*) + Thm ("mult_cross1",num_str mult_cross1), + (*" b ~= 0 ==> (a / b = c ) = (a = b * c)*) + Thm ("mult_cross2",num_str mult_cross2) + (*" d ~= 0 ==> (a = c / d) = (a * d = c)*) + ], scr = EmptyScr}) + calculate_Poly); + + +(*("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))*) +fun eval_is_expanded (thmid:string) _ + (t as (Const("Rational.is'_expanded", _) $ arg)) thy = + if is_expanded arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.true_const))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.false_const))) + | eval_is_expanded _ _ _ _ = NONE; + +val rational_erls = + merge_rls "rational_erls" calculate_Rational + (append_rls "is_expanded" Atools_erls + [Calc ("Rational.is'_expanded", eval_is_expanded "") + ]); + + + +(*.3 'reverse-rewrite-sets' for symbolic computation on rationals: + ================================================================= + A[2] 'cancel_p': . + A[3] 'cancel': . + B[2] 'common_nominator_p': transforms summands in a term [2] + to fractions with the (least) common multiple as nominator. + B[3] 'norm_rational': normalizes arbitrary algebraic terms (without + radicals and transzendental functions) to one canceled fraction, + nominator and denominator in polynomial form. + +In order to meet isac's requirements for interactive and stepwise calculation, +each 'reverse-rewerite-set' consists of an initialization for the interpreter +state and of 4 functions, each of which employs rewriting as much as possible. +The signature of these functions are the same in each 'reverse-rewrite-set' +respectively.*) + +(* ************************************************************************* *) + + +local(*. cancel_p +------------------------ +cancels a single fraction consisting of two (uni- or multivariate) +polynomials WN0609???SK[2] into another such a fraction; examples: + + a^2 + -1*b^2 a + b + -------------------- = --------- + a^2 + -2*a*b + b^2 a + -1*b + + a^2 a + --- = --- + a 1 + +Remark: the reverse ruleset does _NOT_ work properly with other input !.*) +(*WN020824 wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*) + +val {rules, rew_ord=(_,ro),...} = + rep_rls (assoc_rls "make_polynomial"); +(*WN060829 ... make_deriv does not terminate with 1st expl above, + see rational.sml --- investigate rulesets for cancel_p ---*) +val {rules, rew_ord=(_,ro),...} = + rep_rls (assoc_rls "rev_rew_p"); + +val thy = Rational.thy; + +(*.init_state = fn : term -> istate +initialzies the state of the script interpreter. The state is: + +type rrlsstate = (*state for reverse rewriting*) + (term * (*the current formula*) + term * (*the final term*) + rule list (*'reverse rule list' (#)*) + list * (*may be serveral, eg. in norm_rational*) + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) + (term * (*... rewrite with ...*) + term list)) (*... assumptions*) + list); (*derivation from given term to normalform + in reverse order with sym_thm; + (#) could be extracted from here by (map #1)*).*) +(* val {rules, rew_ord=(_,ro),...} = + rep_rls (assoc_rls "rev_rew_p") (*USE ALWAYS, SEE val cancel_p*); + val (thy, eval_rls, ro) =(Rational.thy, Atools_erls, ro) (*..val cancel_p*); + val t = t; + *) +fun init_state thy eval_rls ro t = + let val SOME (t',_) = factout_p_ thy t + val SOME (t'',asm) = cancel_p_ thy t + val der = reverse_deriv thy eval_rls rules ro NONE t' + val der = der @ [(Thm ("real_mult_div_cancel2", + num_str real_mult_div_cancel2), + (t'',asm))] + val rs = (distinct_Thm o (map #1)) der + val rs = filter_out (eq_Thms ["sym_real_add_zero_left", + "sym_real_mult_0", + "sym_real_mult_1" + (*..insufficient,eg.make_Polynomial*)])rs + in (t,t'',[rs(*here only _ONE_ to ease locate_rule*)],der) end; + +(*.locate_rule = fn : rule list -> term -> rule + -> (rule * (term * term list) option) list. + checks a rule R for being a cancel-rule, and if it is, + then return the list of rules (+ the terms they are rewriting to) + which need to be applied before R should be applied. + precondition: the rule is applicable to the argument-term. +arguments: + rule list: the reverse rule list + -> term : ... to which the rule shall be applied + -> rule : ... to be applied to term +value: + -> (rule : a rule rewriting to ... + * (term : ... the resulting term ... + * term list): ... with the assumptions ( //#0). + ) list : there may be several such rules; + the list is empty, if the rule has nothing to do + with cancelation.*) +(* val () = (); + *) +fun locate_rule thy eval_rls ro [rs] t r = + if (id_of_thm r) mem (map (id_of_thm)) rs + then let val ropt = + rewrite_ thy ro eval_rls true (thm_of_thm r) t; + in case ropt of + SOME ta => [(r, ta)] + | NONE => (writeln("### locate_rule: rewrite "^ + (id_of_thm r)^" "^(term2str t)^" = NONE"); + []) end + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) + | locate_rule _ _ _ _ _ _ = + raise error ("locate_rule: doesnt match rev-sets in istate"); + +(*.next_rule = fn : rule list -> term -> rule option + for a given term return the next rules to be done for cancelling. +arguments: + rule list : the reverse rule list + term : the term for which ... +value: + -> rule option: ... this rule is appropriate for cancellation; + there may be no such rule (if the term is canceled already.*) +(* val thy = Rational.thy; + val Rrls {rew_ord=(_,ro),...} = cancel; + val ([rs],t) = (rss,f); + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) + + val (thy, [rs]) = (Rational.thy, revsets); + val Rrls {rew_ord=(_,ro),...} = cancel; + nex [rs] t; + *) +fun next_rule thy eval_rls ro [rs] t = + let val der = make_deriv thy eval_rls rs ro NONE t; + in case der of +(* val (_,r,_)::_ = der; + *) + (_,r,_)::_ => SOME r + | _ => NONE + end + | next_rule _ _ _ _ _ = + raise error ("next_rule: doesnt match rev-sets in istate"); + +(*.val attach_form = f : rule list -> term -> term + -> (rule * (term * term list)) list + checks an input term TI, if it may belong to a current cancellation, by + trying to derive it from the given term TG. +arguments: + term : TG, the last one in the cancellation agreed upon by user + math-eng + -> term: TI, the next one input by the user +value: + -> (rule : the rule to be applied in order to reach TI + * (term : ... obtained by applying the rule ... + * term list): ... and the respective assumptions. + ) list : there may be several such rules; + the list is empty, if the users term does not belong + to a cancellation of the term last agreed upon.*) +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; + +in + +val cancel_p = + Rrls {id = "cancel_p", prepat=[], + rew_ord=("ord_make_polynomial", + ord_make_polynomial false Rational.thy), + erls = rational_erls, + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + (*asm_thm=[("real_mult_div_cancel2","")],*) + scr=Rfuns {init_state = init_state thy Atools_erls ro, + normal_form = cancel_p_ thy, + locate_rule = locate_rule thy Atools_erls ro, + next_rule = next_rule thy Atools_erls ro, + attach_form = attach_form}} +end;(*local*) + + +local(*.ad (1) 'cancel' +------------------------------ +cancels a single fraction consisting of two (uni- or multivariate) +polynomials WN0609???SK[3] into another such a fraction; examples: + + a^2 - b^2 a + b + -------------------- = --------- + a^2 - 2*a*b + b^2 a - *b + +Remark: the reverse ruleset does _NOT_ work properly with other input !.*) +(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*) + +(* +val SOME (Rls {rules=rules,rew_ord=(_,ro),...}) = + assoc'(!ruleset',"expand_binoms"); +*) +val {rules=rules,rew_ord=(_,ro),...} = + rep_rls (assoc_rls "expand_binoms"); +val thy = Rational.thy; + +fun init_state thy eval_rls ro t = + let val SOME (t',_) = factout_ thy t; + val SOME (t'',asm) = cancel_ thy t; + val der = reverse_deriv thy eval_rls rules ro NONE t'; + val der = der @ [(Thm ("real_mult_div_cancel2", + num_str real_mult_div_cancel2), + (t'',asm))] + val rs = map #1 der; + in (t,t'',[rs],der) end; + +fun locate_rule thy eval_rls ro [rs] t r = + if (id_of_thm r) mem (map (id_of_thm)) rs + then let val ropt = + rewrite_ thy ro eval_rls true (thm_of_thm r) t; + in case ropt of + SOME ta => [(r, ta)] + | NONE => (writeln("### locate_rule: rewrite "^ + (id_of_thm r)^" "^(term2str t)^" = NONE"); + []) end + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) + | locate_rule _ _ _ _ _ _ = + raise error ("locate_rule: doesnt match rev-sets in istate"); + +fun next_rule thy eval_rls ro [rs] t = + let val der = make_deriv thy eval_rls rs ro NONE t; + in case der of +(* val (_,r,_)::_ = der; + *) + (_,r,_)::_ => SOME r + | _ => NONE + end + | next_rule _ _ _ _ _ = + raise error ("next_rule: doesnt match rev-sets in istate"); + +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; + +val pat = (term_of o the o (parse thy)) "?r/?s"; +val pre1 = (term_of o the o (parse thy)) "?r is_expanded"; +val pre2 = (term_of o the o (parse thy)) "?s is_expanded"; +val prepat = [([pre1, pre2], pat)]; + +in + + +val cancel = + Rrls {id = "cancel", prepat=prepat, + rew_ord=("ord_make_polynomial", + ord_make_polynomial false Rational.thy), + erls = rational_erls, + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + scr=Rfuns {init_state = init_state thy Atools_erls ro, + normal_form = cancel_ thy, + locate_rule = locate_rule thy Atools_erls ro, + next_rule = next_rule thy Atools_erls ro, + attach_form = attach_form}} +end;(*local*) + + + +local(*.ad [2] 'common_nominator_p' +--------------------------------- +FIXME Beschreibung .*) + + +val {rules=rules,rew_ord=(_,ro),...} = + rep_rls (assoc_rls "make_polynomial"); +(*WN060829 ... make_deriv does not terminate with 1st expl above, + see rational.sml --- investigate rulesets for cancel_p ---*) +val {rules, rew_ord=(_,ro),...} = + rep_rls (assoc_rls "rev_rew_p"); +val thy = Rational.thy; + + +(*.common_nominator_p_ = fn : theory -> term -> (term * term list) option + as defined above*) + +(*.init_state = fn : term -> istate +initialzies the state of the interactive interpreter. The state is: + +type rrlsstate = (*state for reverse rewriting*) + (term * (*the current formula*) + term * (*the final term*) + rule list (*'reverse rule list' (#)*) + list * (*may be serveral, eg. in norm_rational*) + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) + (term * (*... rewrite with ...*) + term list)) (*... assumptions*) + list); (*derivation from given term to normalform + in reverse order with sym_thm; + (#) could be extracted from here by (map #1)*).*) +fun init_state thy eval_rls ro t = + let val SOME (t',_) = common_nominator_p_ thy t; + val SOME (t'',asm) = add_fraction_p_ thy t; + val der = reverse_deriv thy eval_rls rules ro NONE t'; + val der = der @ [(Thm ("real_mult_div_cancel2", + num_str real_mult_div_cancel2), + (t'',asm))] + val rs = (distinct_Thm o (map #1)) der; + val rs = filter_out (eq_Thms ["sym_real_add_zero_left", + "sym_real_mult_0", + "sym_real_mult_1"]) rs; + in (t,t'',[rs(*here only _ONE_*)],der) end; + +(* use"knowledge/Rational.ML"; + *) + +(*.locate_rule = fn : rule list -> term -> rule + -> (rule * (term * term list) option) list. + checks a rule R for being a cancel-rule, and if it is, + then return the list of rules (+ the terms they are rewriting to) + which need to be applied before R should be applied. + precondition: the rule is applicable to the argument-term. +arguments: + rule list: the reverse rule list + -> term : ... to which the rule shall be applied + -> rule : ... to be applied to term +value: + -> (rule : a rule rewriting to ... + * (term : ... the resulting term ... + * term list): ... with the assumptions ( //#0). + ) list : there may be several such rules; + the list is empty, if the rule has nothing to do + with cancelation.*) +(* val () = (); + *) +fun locate_rule thy eval_rls ro [rs] t r = + if (id_of_thm r) mem (map (id_of_thm)) rs + then let val ropt = + rewrite_ thy ro eval_rls true (thm_of_thm r) t; + in case ropt of + SOME ta => [(r, ta)] + | NONE => (writeln("### locate_rule: rewrite "^ + (id_of_thm r)^" "^(term2str t)^" = NONE"); + []) end + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) + | locate_rule _ _ _ _ _ _ = + raise error ("locate_rule: doesnt match rev-sets in istate"); + +(*.next_rule = fn : rule list -> term -> rule option + for a given term return the next rules to be done for cancelling. +arguments: + rule list : the reverse rule list + term : the term for which ... +value: + -> rule option: ... this rule is appropriate for cancellation; + there may be no such rule (if the term is canceled already.*) +(* val thy = Rational.thy; + val Rrls {rew_ord=(_,ro),...} = cancel; + val ([rs],t) = (rss,f); + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) + + val (thy, [rs]) = (Rational.thy, revsets); + val Rrls {rew_ord=(_,ro),...} = cancel; + nex [rs] t; + *) +fun next_rule thy eval_rls ro [rs] t = + let val der = make_deriv thy eval_rls rs ro NONE t; + in case der of +(* val (_,r,_)::_ = der; + *) + (_,r,_)::_ => SOME r + | _ => NONE + end + | next_rule _ _ _ _ _ = + raise error ("next_rule: doesnt match rev-sets in istate"); + +(*.val attach_form = f : rule list -> term -> term + -> (rule * (term * term list)) list + checks an input term TI, if it may belong to a current cancellation, by + trying to derive it from the given term TG. +arguments: + term : TG, the last one in the cancellation agreed upon by user + math-eng + -> term: TI, the next one input by the user +value: + -> (rule : the rule to be applied in order to reach TI + * (term : ... obtained by applying the rule ... + * term list): ... and the respective assumptions. + ) list : there may be several such rules; + the list is empty, if the users term does not belong + to a cancellation of the term last agreed upon.*) +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; + +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v"; +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u "; +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v"; +val prepat = [([HOLogic.true_const], pat0), + ([HOLogic.true_const], pat1), + ([HOLogic.true_const], pat2)]; + +in + +(*11.02 schnelle L"osung f"ur RL: Bruch auch gek"urzt; + besser w"are: auf 1 gemeinsamen Bruchstrich, Nenner und Z"ahler unvereinfacht + dh. wie common_nominator_p_, aber auf 1 Bruchstrich*) +val common_nominator_p = + Rrls {id = "common_nominator_p", prepat=prepat, + rew_ord=("ord_make_polynomial", + ord_make_polynomial false Rational.thy), + erls = rational_erls, + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + scr=Rfuns {init_state = init_state thy Atools_erls ro, + normal_form = add_fraction_p_ thy,(*FIXME.WN0211*) + locate_rule = locate_rule thy Atools_erls ro, + next_rule = next_rule thy Atools_erls ro, + attach_form = attach_form}} +end;(*local*) + + +local(*.ad [2] 'common_nominator' +--------------------------------- +FIXME Beschreibung .*) + + +val {rules=rules,rew_ord=(_,ro),...} = + rep_rls (assoc_rls "make_polynomial"); +val thy = Rational.thy; + + +(*.common_nominator_ = fn : theory -> term -> (term * term list) option + as defined above*) + +(*.init_state = fn : term -> istate +initialzies the state of the interactive interpreter. The state is: + +type rrlsstate = (*state for reverse rewriting*) + (term * (*the current formula*) + term * (*the final term*) + rule list (*'reverse rule list' (#)*) + list * (*may be serveral, eg. in norm_rational*) + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) + (term * (*... rewrite with ...*) + term list)) (*... assumptions*) + list); (*derivation from given term to normalform + in reverse order with sym_thm; + (#) could be extracted from here by (map #1)*).*) +fun init_state thy eval_rls ro t = + let val SOME (t',_) = common_nominator_ thy t; + val SOME (t'',asm) = add_fraction_ thy t; + val der = reverse_deriv thy eval_rls rules ro NONE t'; + val der = der @ [(Thm ("real_mult_div_cancel2", + num_str real_mult_div_cancel2), + (t'',asm))] + val rs = (distinct_Thm o (map #1)) der; + val rs = filter_out (eq_Thms ["sym_real_add_zero_left", + "sym_real_mult_0", + "sym_real_mult_1"]) rs; + in (t,t'',[rs(*here only _ONE_*)],der) end; + +(* use"knowledge/Rational.ML"; + *) + +(*.locate_rule = fn : rule list -> term -> rule + -> (rule * (term * term list) option) list. + checks a rule R for being a cancel-rule, and if it is, + then return the list of rules (+ the terms they are rewriting to) + which need to be applied before R should be applied. + precondition: the rule is applicable to the argument-term. +arguments: + rule list: the reverse rule list + -> term : ... to which the rule shall be applied + -> rule : ... to be applied to term +value: + -> (rule : a rule rewriting to ... + * (term : ... the resulting term ... + * term list): ... with the assumptions ( //#0). + ) list : there may be several such rules; + the list is empty, if the rule has nothing to do + with cancelation.*) +(* val () = (); + *) +fun locate_rule thy eval_rls ro [rs] t r = + if (id_of_thm r) mem (map (id_of_thm)) rs + then let val ropt = + rewrite_ thy ro eval_rls true (thm_of_thm r) t; + in case ropt of + SOME ta => [(r, ta)] + | NONE => (writeln("### locate_rule: rewrite "^ + (id_of_thm r)^" "^(term2str t)^" = NONE"); + []) end + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[]) + | locate_rule _ _ _ _ _ _ = + raise error ("locate_rule: doesnt match rev-sets in istate"); + +(*.next_rule = fn : rule list -> term -> rule option + for a given term return the next rules to be done for cancelling. +arguments: + rule list : the reverse rule list + term : the term for which ... +value: + -> rule option: ... this rule is appropriate for cancellation; + there may be no such rule (if the term is canceled already.*) +(* val thy = Rational.thy; + val Rrls {rew_ord=(_,ro),...} = cancel; + val ([rs],t) = (rss,f); + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*) + + val (thy, [rs]) = (Rational.thy, revsets); + val Rrls {rew_ord=(_,ro),...} = cancel_p; + nex [rs] t; + *) +fun next_rule thy eval_rls ro [rs] t = + let val der = make_deriv thy eval_rls rs ro NONE t; + in case der of +(* val (_,r,_)::_ = der; + *) + (_,r,_)::_ => SOME r + | _ => NONE + end + | next_rule _ _ _ _ _ = + raise error ("next_rule: doesnt match rev-sets in istate"); + +(*.val attach_form = f : rule list -> term -> term + -> (rule * (term * term list)) list + checks an input term TI, if it may belong to a current cancellation, by + trying to derive it from the given term TG. +arguments: + term : TG, the last one in the cancellation agreed upon by user + math-eng + -> term: TI, the next one input by the user +value: + -> (rule : the rule to be applied in order to reach TI + * (term : ... obtained by applying the rule ... + * term list): ... and the respective assumptions. + ) list : there may be several such rules; + the list is empty, if the users term does not belong + to a cancellation of the term last agreed upon.*) +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*) + []:(rule * (term * term list)) list; + +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v"; +val pat01 = (term_of o the o (parse thy)) "?r/?s-?u/?v"; +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u "; +val pat11 = (term_of o the o (parse thy)) "?r/?s-?u "; +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v"; +val pat21 = (term_of o the o (parse thy)) "?r -?u/?v"; +val prepat = [([HOLogic.true_const], pat0), + ([HOLogic.true_const], pat01), + ([HOLogic.true_const], pat1), + ([HOLogic.true_const], pat11), + ([HOLogic.true_const], pat2), + ([HOLogic.true_const], pat21)]; + + +in + +val common_nominator = + Rrls {id = "common_nominator", prepat=prepat, + rew_ord=("ord_make_polynomial", + ord_make_polynomial false Rational.thy), + erls = rational_erls, + calc = [("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))], + (*asm_thm=[("real_mult_div_cancel2","")],*) + scr=Rfuns {init_state = init_state thy Atools_erls ro, + normal_form = add_fraction_ (*NOT common_nominator_*) thy, + locate_rule = locate_rule thy Atools_erls ro, + next_rule = next_rule thy Atools_erls ro, + attach_form = attach_form}} + +end;(*local*) + + +(*##*) +end;(*struct*) + +open RationalI; +(*##*) + +(*.the expression contains + - * ^ / only ?.*) +fun is_ratpolyexp (Free _) = true + | is_ratpolyexp (Const ("op +",_) $ Free _ $ Free _) = true + | is_ratpolyexp (Const ("op -",_) $ Free _ $ Free _) = true + | is_ratpolyexp (Const ("op *",_) $ Free _ $ Free _) = true + | is_ratpolyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true + | is_ratpolyexp (Const ("HOL.divide",_) $ Free _ $ Free _) = true + | is_ratpolyexp (Const ("op +",_) $ t1 $ t2) = + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) + | is_ratpolyexp (Const ("op -",_) $ t1 $ t2) = + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) + | is_ratpolyexp (Const ("op *",_) $ t1 $ t2) = + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) + | is_ratpolyexp (Const ("Atools.pow",_) $ t1 $ t2) = + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) + | is_ratpolyexp (Const ("HOL.divide",_) $ t1 $ t2) = + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2)) + | is_ratpolyexp _ = false; + +(*("is_ratpolyexp", ("Rational.is'_ratpolyexp", eval_is_ratpolyexp ""))*) +fun eval_is_ratpolyexp (thmid:string) _ + (t as (Const("Rational.is'_ratpolyexp", _) $ arg)) thy = + if is_ratpolyexp arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.true_const))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, HOLogic.false_const))) + | eval_is_ratpolyexp _ _ _ _ = NONE; + + + +(*-------------------18.3.03 --> struct <-----------vvv--*) +val add_fractions_p = common_nominator_p; (*FIXXXME:eilig f"ur norm_Rational*) + +(*.discard binary minus, shift unary minus into -1*; + unary minus before numerals are put into the numeral by parsing; + contains absolute minimum of thms for context in norm_Rational .*) +val discard_minus = prep_rls( + Rls {id = "discard_minus", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("real_diff_minus", num_str real_diff_minus), + (*"a - b = a + -1 * b"*) + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)) + (*- ?z = "-1 * ?z"*) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }):rls; +(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*) +val powers_erls = prep_rls( + Rls {id = "powers_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"), + Calc ("Atools.is'_even",eval_is_even "#is_even_"), + Calc ("op <",eval_equ "#less_"), + Thm ("not_false", not_false), + Thm ("not_true", not_true), + Calc ("op +",eval_binop "#add_") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +(*.all powers over + distributed; atoms over * collected, other distributed + contains absolute minimum of thms for context in norm_Rational .*) +val powers = prep_rls( + Rls {id = "powers", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = powers_erls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("realpow_multI", num_str realpow_multI), + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*) + Thm ("realpow_pow",num_str realpow_pow), + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*) + Thm ("realpow_oneI",num_str realpow_oneI), + (*"r ^^^ 1 = r"*) + Thm ("realpow_minus_even",num_str realpow_minus_even), + (*"n is_even ==> (- r) ^^^ n = r ^^^ n" ?-->discard_minus?*) + Thm ("realpow_minus_odd",num_str realpow_minus_odd), + (*"Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"*) + + (*----- collect atoms over * -----*) + Thm ("realpow_two_atom",num_str realpow_two_atom), + (*"r is_atom ==> r * r = r ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r is_atom ==> r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("realpow_addI_atom",num_str realpow_addI_atom), + (*"r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"*) + + (*----- distribute none-atoms -----*) + Thm ("realpow_def_atom",num_str realpow_def_atom), + (*"[| 1 < n; not(r is_atom) |]==>r ^^^ n = r * r ^^^ (n + -1)"*) + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI), + (*"1 ^^^ n = 1"*) + Calc ("op +",eval_binop "#add_") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +(*.contains absolute minimum of thms for context in norm_Rational.*) +val rat_mult_divide = prep_rls( + Rls {id = "rat_mult_divide", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Thm ("rat_mult",num_str rat_mult), + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2], + otherwise inv.to a / b / c = ...*) + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), + (*"?a / ?b * ?c = ?a * ?c / ?b" order weights x^^^n too much + and does not commute a / b * c ^^^ 2 !*) + + Thm ("real_divide_divide1_eq", real_divide_divide1_eq), + (*"?x / (?y / ?z) = ?x * ?z / ?y"*) + Thm ("real_divide_divide2_eq", real_divide_divide2_eq), + (*"?x / ?y / ?z = ?x / (?y * ?z)"*) + Calc ("HOL.divide" ,eval_cancel "#divide_") + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(*.contains absolute minimum of thms for context in norm_Rational.*) +val reduce_0_1_2 = prep_rls( + Rls{id = "reduce_0_1_2", preconds = [], rew_ord = ("dummy_ord", dummy_ord), + erls = e_rls,srls = Erls,calc = [],(*asm_thm = [],*) + rules = [(*Thm ("real_divide_1",num_str real_divide_1), + "?x / 1 = ?x" unnecess.for normalform*) + Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + (*Thm ("real_mult_minus1",num_str real_mult_minus1), + "-1 * z = - z"*) + (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel), + "- ?x * - ?y = ?x * ?y"*) + + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + (*Thm ("real_add_minus",num_str real_add_minus), + "?z + - ?z = 0"*) + + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_0_divide",num_str real_0_divide) + (*"0 / ?x = 0"*) + ], scr = EmptyScr}:rls); + +(*erls for calculate_Rational; + make local with FIXX@ME result:term *term list WN0609???SKMG*) +val norm_rat_erls = prep_rls( + Rls {id = "norm_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [Calc ("Atools.is'_const",eval_const "#is_const_") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +(*.consists of rls containing the absolute minimum of thms.*) +(*040209: this version has been used by RL for his equations, +which is now replaced by MGs version below +vvv OLD VERSION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*) +val norm_Rational = prep_rls( + Rls {id = "norm_Rational", preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [(*sequence given by operator precedence*) + Rls_ discard_minus, + Rls_ powers, + Rls_ rat_mult_divide, + Rls_ expand, + Rls_ reduce_0_1_2, + (*^^^^^^^^^ from RL -- not the latest one vvvvvvvvv*) + Rls_ order_add_mult, + Rls_ collect_numerals, + Rls_ add_fractions_p, + Rls_ cancel_p + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls); +val norm_Rational_parenthesized = prep_rls( + Seq {id = "norm_Rational_parenthesized", preconds = []:term list, + rew_ord = ("dummy_ord", dummy_ord), + erls = Atools_erls, srls = Erls, + calc = [], (*asm_thm = [],*) + rules = [Rls_ norm_Rational, (*from RL -- not the latest one*) + Rls_ discard_parentheses + ], + scr = EmptyScr + }:rls); + + +(*-------------------18.3.03 --> struct <-----------^^^--*) + + + +theory' := overwritel (!theory', [("Rational.thy",Rational.thy)]); + + +(*WN030318???SK: simplifies all but cancel and common_nominator*) +val simplify_rational = + merge_rls "simplify_rational" expand_binoms + (append_rls "divide" calculate_Rational + [Thm ("real_divide_1",num_str real_divide_1), + (*"?x / 1 = ?x"*) + Thm ("rat_mult",num_str rat_mult), + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq), + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2], + otherwise inv.to a / b / c = ...*) + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq), + (*"?a / ?b * ?c = ?a * ?c / ?b"*) + Thm ("add_minus",num_str add_minus), + (*"?a + ?b - ?b = ?a"*) + Thm ("add_minus1",num_str add_minus1), + (*"?a - ?b + ?b = ?a"*) + Thm ("real_divide_minus1",num_str real_divide_minus1) + (*"?x / -1 = - ?x"*) +(* +, + Thm ("",num_str ) +*) + ]); + +(*---------vvv-------------MG ab 1.07.2003--------------vvv-----------*) + +(* ------------------------------------------------------------------ *) +(* Simplifier für beliebige Buchterme *) +(* ------------------------------------------------------------------ *) +(*----------------------- norm_Rational_mg ---------------------------*) +(*. description of the simplifier see MG-DA.p.56ff .*) +(* ------------------------------------------------------------------- *) +val common_nominator_p_rls = prep_rls( + Rls {id = "common_nominator_p_rls", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], + rules = + [Rls_ common_nominator_p + (*FIXME.WN0401 ? redesign Rrls - use exhaustively on a term ? + FIXME.WN0510 unnecessary nesting: introduce RRls_ : rls -> rule*) + ], + scr = EmptyScr}); +(* ------------------------------------------------------------------- *) +val cancel_p_rls = prep_rls( + Rls {id = "cancel_p_rls", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], + rules = + [Rls_ cancel_p + (*FIXME.WN.0401 ? redesign Rrls - use exhaustively on a term ?*) + ], + scr = EmptyScr}); +(* -------------------------------------------------------------------- *) +(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions; + used in initial part norm_Rational_mg, see example DA-M02-main.p.60.*) +val rat_mult_poly = prep_rls( + Rls {id = "rat_mult_poly", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = append_rls "e_rls-is_polyexp" e_rls + [Calc ("Poly.is'_polyexp", eval_is_polyexp "")], + srls = Erls, calc = [], + rules = + [Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r) + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) + ], + scr = EmptyScr}); +(* ------------------------------------------------------------------ *) +(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions; + used in looping part norm_Rational_rls, see example DA-M02-main.p.60 + .. WHERE THE LATTER DOES ALWAYS WORK, BECAUSE erls = e_rls, + I.E. THE RESPECTIVE ASSUMPTION IS STORED AND Thm APPLIED; WN051028 + ... WN0609???MG.*) +val rat_mult_div_pow = prep_rls( + Rls {id = "rat_mult_div_pow", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, + (*FIXME.WN051028 append_rls "e_rls-is_polyexp" e_rls + [Calc ("Poly.is'_polyexp", eval_is_polyexp "")], + with this correction ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ we get + error "rational.sml.sml: diff.behav. in norm_Rational_mg 29" etc. + thus we decided to go on with this flaw*) + srls = Erls, calc = [], + rules = [Thm ("rat_mult",num_str rat_mult), + (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*) + Thm ("rat_mult_poly_l",num_str rat_mult_poly_l), + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*) + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r), + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*) + + Thm ("real_divide_divide1_mg", real_divide_divide1_mg), + (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*) + Thm ("real_divide_divide1_eq", real_divide_divide1_eq), + (*"?x / (?y / ?z) = ?x * ?z / ?y"*) + Thm ("real_divide_divide2_eq", real_divide_divide2_eq), + (*"?x / ?y / ?z = ?x / (?y * ?z)"*) + Calc ("HOL.divide" ,eval_cancel "#divide_"), + + Thm ("rat_power", num_str rat_power) + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* ------------------------------------------------------------------ *) +val rat_reduce_1 = prep_rls( + Rls {id = "rat_reduce_1", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], + rules = [Thm ("real_divide_1",num_str real_divide_1), + (*"?x / 1 = ?x"*) + Thm ("real_mult_1",num_str real_mult_1) + (*"1 * z = z"*) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* ------------------------------------------------------------------ *) +(*. looping part of norm_Rational(*_mg*) .*) +val norm_Rational_rls = prep_rls( + Rls {id = "norm_Rational_rls", preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [Rls_ common_nominator_p_rls, + Rls_ rat_mult_div_pow, + Rls_ make_rat_poly_with_parentheses, + Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*) + Rls_ rat_reduce_1 + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* ------------------------------------------------------------------ *) +(*040109 'norm_Rational'(by RL) replaced by 'norm_Rational_mg'(MG) + just be renaming:*) +val norm_Rational(*_mg*) = prep_rls( + Seq {id = "norm_Rational"(*_mg*), preconds = [], + rew_ord = ("dummy_ord",dummy_ord), + erls = norm_rat_erls, srls = Erls, calc = [], + rules = [Rls_ discard_minus_, + Rls_ rat_mult_poly,(* removes double fractions like a/b/c *) + Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*) + Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*) + Rls_ norm_Rational_rls, (* the main rls, looping (#) *) + Rls_ discard_parentheses_ (* mult only *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +(* ------------------------------------------------------------------ *) + + +ruleset' := overwritelthy thy (!ruleset', + [("calculate_Rational", calculate_Rational), + ("calc_rat_erls",calc_rat_erls), + ("rational_erls", rational_erls), + ("cancel_p", cancel_p), + ("cancel", cancel), + ("common_nominator_p", common_nominator_p), + ("common_nominator_p_rls", common_nominator_p_rls), + ("common_nominator" , common_nominator), + ("discard_minus", discard_minus), + ("powers_erls", powers_erls), + ("powers", powers), + ("rat_mult_divide", rat_mult_divide), + ("reduce_0_1_2", reduce_0_1_2), + ("rat_reduce_1", rat_reduce_1), + ("norm_rat_erls", norm_rat_erls), + ("norm_Rational", norm_Rational), + ("norm_Rational_rls", norm_Rational_rls), + ("norm_Rational_parenthesized", norm_Rational_parenthesized), + ("rat_mult_poly", rat_mult_poly), + ("rat_mult_div_pow", rat_mult_div_pow), + ("cancel_p_rls", cancel_p_rls) + ]); + +calclist':= overwritel (!calclist', + [("is_expanded", ("Rational.is'_expanded", eval_is_expanded "")) + ]); + +(** problems **) + +store_pbt + (prep_pbt Rational.thy "pbl_simp_rat" [] e_pblID + (["rational","simplification"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_ratpolyexp"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "Simplify t_", + [["simplification","of_rationals"]])); + +(** methods **) + +(*WN061025 this methods script is copied from (auto-generated) script + of norm_Rational in order to ease repair on inform*) +store_met + (prep_met Rational.thy "met_simp_rat" [] e_metID + (["simplification","of_rationals"], + [("#Given" ,["term t_"]), + ("#Where" ,["t_ is_ratpolyexp"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", + rls' = e_rls, + calc = [], srls = e_rls, + prls = append_rls "simplification_of_rationals_prls" e_rls + [(*for preds in where_*) + Calc ("Rational.is'_ratpolyexp", + eval_is_ratpolyexp "")], + crls = e_rls, nrls = norm_Rational_rls}, +"Script SimplifyScript (t_::real) = \ +\ ((Try (Rewrite_Set discard_minus_ False) @@ \ +\ Try (Rewrite_Set rat_mult_poly False) @@ \ +\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@ \ +\ Try (Rewrite_Set cancel_p_rls False) @@ \ +\ (Repeat \ +\ ((Try (Rewrite_Set common_nominator_p_rls False) @@ \ +\ Try (Rewrite_Set rat_mult_div_pow False) @@ \ +\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@\ +\ Try (Rewrite_Set cancel_p_rls False) @@ \ +\ Try (Rewrite_Set rat_reduce_1 False)))) @@ \ +\ Try (Rewrite_Set discard_parentheses_ False)) \ +\ t_)" + )); + +(* use"../Knowledge/Rational.ML"; + use"Knowledge/Rational.ML"; + use"Rational.ML"; + *) + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Rational.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Rational.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,76 @@ +(* rationals, i.e. fractions of multivariate polynomials over the real field + author: isac team + Copyright (c) isac team 2002 + Use is subject to license terms. + + depends on Poly (and not on Atools), because + fractions with _normalized_ polynomials are canceled, added, etc. + + use_thy_only"Knowledge/Rational"; + use_thy"../Knowledge/Rational"; + use_thy"Knowledge/Rational"; + + remove_thy"Rational"; + use_thy"Knowledge/Isac"; + use_thy_only"Knowledge/Rational"; + +*) + +Rational = Poly + + +consts + + is'_expanded :: "real => bool" ("_ is'_expanded") (*RL->Poly.thy*) + is'_ratpolyexp :: "real => bool" ("_ is'_ratpolyexp") + +rules (*.not contained in Isabelle2002, + stated as axioms, TODO: prove as theorems*) + + mult_cross "[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)" + mult_cross1 " b ~= 0 ==> (a / b = c ) = (a = b * c)" + mult_cross2 " d ~= 0 ==> (a = c / d) = (a * d = c)" + + add_minus "a + b - b = a"(*RL->Poly.thy*) + add_minus1 "a - b + b = a"(*RL->Poly.thy*) + + rat_mult "a / b * (c / d) = a * c / (b * d)"(*?Isa02*) + rat_mult2 "a / b * c = a * c / b "(*?Isa02*) + + rat_mult_poly_l "c is_polyexp ==> c * (a / b) = c * a / b" + rat_mult_poly_r "c is_polyexp ==> (a / b) * c = a * c / b" + +(*real_times_divide1_eq .. Isa02*) + real_times_divide_1_eq "-1 * (c / d) =-1 * c / d " + real_times_divide_num "a is_const ==> \ + \a * (c / d) = a * c / d " + + real_mult_div_cancel2 "k ~= 0 ==> m * k / (n * k) = m / n" +(*real_mult_div_cancel1 "k ~= 0 ==> k * m / (k * n) = m / n"..Isa02*) + + real_divide_divide1 "y ~= 0 ==> (u / v) / (y / z) = (u / v) * (z / y)" + real_divide_divide1_mg "y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)" +(*real_divide_divide2_eq "x / y / z = x / (y * z)"..Isa02*) + + rat_power "(a / b)^^^n = (a^^^n) / (b^^^n)" + + + rat_add "[| a is_const; b is_const; c is_const; d is_const |] ==> \ + \a / c + b / d = (a * d + b * c) / (c * d)" + rat_add_assoc "[| a is_const; b is_const; c is_const; d is_const |] ==> \ + \a / c +(b / d + e) = (a * d + b * c)/(d * c) + e" + rat_add1 "[| a is_const; b is_const; c is_const |] ==> \ + \a / c + b / c = (a + b) / c" + rat_add1_assoc "[| a is_const; b is_const; c is_const |] ==> \ + \a / c + (b / c + e) = (a + b) / c + e" + rat_add2 "[| a is_const; b is_const; c is_const |] ==> \ + \a / c + b = (a + b * c) / c" + rat_add2_assoc "[| a is_const; b is_const; c is_const |] ==> \ + \a / c + (b + e) = (a + b * c) / c + e" + rat_add3 "[| a is_const; b is_const; c is_const |] ==> \ + \a + b / c = (a * c + b) / c" + rat_add3_assoc "[| a is_const; b is_const; c is_const |] ==> \ + \a + (b / c + e) = (a * c + b) / c + e" + + + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Root.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Root.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,299 @@ +(* collecting all knowledge for Root + created by: + date: + changed by: rlang + last change by: rlang + date: 02.10.24 +*) + +(* use"../knowledge/Root.ML"; + use"Knowledge/Root.ML"; + use"Root.ML"; + + remove_thy"Root"; + use_thy"Knowledge/Isac"; + + use"ROOT.ML"; + cd"knowledge"; + *) +"******* Root.ML begin *******"; +theory' := overwritel (!theory', [("Root.thy",Root.thy)]); +(*-------------------------functions---------------------*) +(*evaluation square-root over the integers*) +fun eval_sqrt (thmid:string) (op_:string) (t as + (Const(op0,t0) $ arg)) thy = + (case arg of + Free (n1,t1) => + (case int_of_str n1 of + SOME ni => + if ni < 0 then NONE + else + let val fact = squfact ni; + in if fact*fact = ni + then SOME ("#sqrt #"^(string_of_int ni)^" = #" + ^(string_of_int (if ni = 0 then 0 + else ni div fact)), + Trueprop $ mk_equality (t, term_of_num t1 fact)) + else if fact = 1 then NONE + else SOME ("#sqrt #"^(string_of_int ni)^" = sqrt (#" + ^(string_of_int fact)^" * #" + ^(string_of_int fact)^" * #" + ^(string_of_int (ni div (fact*fact))^")"), + Trueprop $ + (mk_equality + (t, + (mk_factroot op0 t1 fact + (ni div (fact*fact)))))) + end + | NONE => NONE) + | _ => NONE) + + | eval_sqrt _ _ _ _ = NONE; +(*val (thmid, op_, t as Const(op0,t0) $ arg) = ("","", str2term "sqrt 0"); +> eval_sqrt thmid op_ t thy; +> val Free (n1,t1) = arg; +> val SOME ni = int_of_str n1; +*) + +calclist':= overwritel (!calclist', + [("SQRT" ,("Root.sqrt" ,eval_sqrt "#sqrt_")) + (*different types for 'sqrt 4' --- 'Calculate sqrt_'*) + ]); + + +local (* Vers. 7.10.99.A *) + +open Term; (* for type order = EQUAL | LESS | GREATER *) + +fun pr_ord EQUAL = "EQUAL" + | pr_ord LESS = "LESS" + | pr_ord GREATER = "GREATER"; + +fun dest_hd' (Const (a, T)) = (* ~ term.ML *) + (case a of "Root.sqrt" => ((("|||", 0), T), 0) (*WN greatest *) + | _ => (((a, 0), T), 0)) + | dest_hd' (Free (a, T)) = (((a, 0), T), 1) + | dest_hd' (Var v) = (v, 2) + | dest_hd' (Bound i) = ((("", i), dummyT), 3) + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); +fun size_of_term' (Const(str,_) $ t) = + (case str of "Root.sqrt" => (1000 + size_of_term' t) + | _ => 1 + size_of_term' t) + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body + | size_of_term' (f $ t) = size_of_term' f + size_of_term' t + | size_of_term' _ = 1; +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) + | term_ord' pr thy (t, u) = + (if pr then + let + val (f, ts) = strip_comb t and (g, us) = strip_comb u; + val _=writeln("t= f@ts= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\""); + val _=writeln("u= g@us= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\""); + val _=writeln("size_of_term(t,u)= ("^ + (string_of_int(size_of_term' t))^", "^ + (string_of_int(size_of_term' u))^")"); + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); + val _=writeln("terms_ord(ts,us) = "^ + ((pr_ord o terms_ord str false)(ts,us))); + val _=writeln("-------"); + in () end + else (); + case int_ord (size_of_term' t, size_of_term' u) of + EQUAL => + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) + | ord => ord) + end + | ord => ord) +and hd_ord (f, g) = (* ~ term.ML *) + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) +and terms_ord str pr (ts, us) = + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); + +in +(* associates a+(b+c) => (a+b)+c = a+b+c ... avoiding parentheses + by (1) size_of_term: less(!) to right, size_of 'sqrt (...)' = 1 + (2) hd_ord: greater to right, 'sqrt' < numerals < variables + (3) terms_ord: recurs. on args, greater to right +*) + +(*args + pr: print trace, WN0509 'sqrt_right true' not used anymore + thy: + subst: no bound variables, only Root.sqrt + tu: the terms to compare (t1, t2) ... *) +fun sqrt_right (pr:bool) thy (_:subst) tu = + (term_ord' pr thy(***) tu = LESS ); +end; + +rew_ord' := overwritel (!rew_ord', +[("termlessI", termlessI), + ("sqrt_right", sqrt_right false (theory "Pure")) + ]); + +(*-------------------------rulse-------------------------*) +val Root_crls = + append_rls "Root_crls" Atools_erls + [Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"), + Calc ("HOL.divide",eval_cancel "#divide_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#sub_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("op =",eval_equal "#equal_") + ]; + +val Root_erls = + append_rls "Root_erls" Atools_erls + [Thm ("real_unari_minus",num_str real_unari_minus), + Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"), + Calc ("HOL.divide",eval_cancel "#divide_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#sub_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("op =",eval_equal "#equal_") + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("Root_erls",Root_erls) (*FIXXXME:del with rls.rls'*) + ]); + +val make_rooteq = prep_rls( + Rls{id = "make_rooteq", preconds = []:term list, + rew_ord = ("sqrt_right", sqrt_right false Root.thy), + erls = Atools_erls, srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_diff_minus",num_str real_diff_minus), + (*"a - b = a + (-1) * b"*) + + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) + + Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) + Thm ("real_mult_assoc",num_str real_mult_assoc), (**) + Thm ("real_add_commute",num_str real_add_commute), (**) + Thm ("real_add_left_commute",num_str real_add_left_commute), (**) + Thm ("real_add_assoc",num_str real_add_assoc), (**) + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("make_rooteq", make_rooteq) + ]); + +val expand_rootbinoms = prep_rls( + Rls{id = "expand_rootbinoms", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = Atools_erls, srls = Erls, + calc = [], + (*asm_thm = [],*) + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), + (*"(a + b)*(a + b) = ...*) + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) + Thm ("real_minus_binom_times",num_str real_minus_binom_times), + (*"(a - b)*(a - b) = ...*) + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) + (*RL 020915*) + Thm ("real_pp_binom_times",num_str real_pp_binom_times), + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) + Thm ("real_pm_binom_times",num_str real_pm_binom_times), + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) + Thm ("real_mp_binom_times",num_str real_mp_binom_times), + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*) + Thm ("real_mm_binom_times",num_str real_mm_binom_times), + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*) + Thm ("realpow_mul",num_str realpow_mul), + (*(a*b)^^^n = a^^^n * b^^^n*) + + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), (*"0 + z = z"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#sub_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("HOL.divide" ,eval_cancel "#divide_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + Calc ("Atools.pow", eval_binop "#power_"), + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op -", eval_binop "#sub_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("HOL.divide" ,eval_cancel "#divide_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + Calc ("Atools.pow", eval_binop "#power_") + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); + + +ruleset' := overwritelthy thy (!ruleset', + [("expand_rootbinoms", expand_rootbinoms) + ]); +"******* Root.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Root.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Root.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,53 @@ +(* theory collecting all knowledge for Root + created by: + date: + changed by: rlang + last change by: rlang + date: 02.10.21 +*) + +(* use_thy_only"Knowledge/Root"; + remove_thy"Root"; + use_thy"Knowledge/Isac"; +*) +Root = Simplify + + +(*-------------------- consts------------------------------------------------*) +consts + + sqrt :: "real => real" (*"(sqrt _ )" [80] 80*) + nroot :: "[real, real] => real" + +(*----------------------scripts-----------------------*) + +(*-------------------- rules------------------------------------------------*) +rules (*.not contained in Isabelle2002, + stated as axioms, TODO: prove as theorems; + theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*) + + root_plus_minus "0 <= b ==> \ + \(a^^^2 = b) = ((a = sqrt b) | (a = (-1)*sqrt b))" + root_false "b < 0 ==> (a^^^2 = b) = False" + + (* for expand_rootbinom *) + real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d" + real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d" + real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d" + real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d" + real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" + real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3" + realpow_mul "(a*b)^^^n = a^^^n * b^^^n" + + real_diff_minus "a - b = a + (-1) * b" + real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2" + real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2" + real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2" + real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2" + real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2" + real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2" + + real_root_positive "0 <= a ==> (x ^^^ 2 = a) = (x = sqrt a)" + real_root_negative "a < 0 ==> (x ^^^ 2 = a) = False" + + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootEq.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootEq.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,505 @@ +(*.(c) by Richard Lang, 2003 .*) +(* theory collecting all knowledge for RootEquations + created by: rlang + date: 02.09 + changed by: rlang + last change by: rlang + date: 02.11.14 +*) + +(* use"Knowledge/RootEq.ML"; + use"RootEq.ML"; + + use"ROOT.ML"; + cd"knowledge"; + + remove_thy"RootEq"; + use_thy"Knowledge/Isac"; + *) +"******* RootEq.ML begin *******"; + +theory' := overwritel (!theory', [("RootEq.thy",RootEq.thy)]); +(*-------------------------functions---------------------*) +(* true if bdv is under sqrt of a Equation*) +fun is_rootTerm_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun findroot (_ $ _ $ _ $ _) v = raise error("is_rootTerm_in:") + (* at the moment there is no term like this, but ....*) + | findroot (t as (Const ("Root.nroot",_) $ _ $ t3)) v = coeff_in t3 v + | findroot (_ $ t2 $ t3) v = (findroot t2 v) orelse (findroot t3 v) + | findroot (t as (Const ("Root.sqrt",_) $ t2)) v = coeff_in t2 v + | findroot (_ $ t2) v = (findroot t2 v) + | findroot _ _ = false; + in + findroot t v + end; + + fun is_sqrtTerm_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun findsqrt (_ $ _ $ _ $ _) v = raise error("is_sqrteqation_in:") + (* at the moment there is no term like this, but ....*) + | findsqrt (_ $ t1 $ t2) v = (findsqrt t1 v) orelse (findsqrt t2 v) + | findsqrt (t as (Const ("Root.sqrt",_) $ a)) v = coeff_in a v + | findsqrt (_ $ t1) v = (findsqrt t1 v) + | findsqrt _ _ = false; + in + findsqrt t v + end; + +(* RL: 030518: Is in the rightest subterm of a term a sqrt with bdv, +and the subterm ist connected with + or * --> is normalized*) + fun is_normSqrtTerm_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun isnorm (_ $ _ $ _ $ _) v = raise error("is_normSqrtTerm_in:") + (* at the moment there is no term like this, but ....*) + | isnorm (Const ("op +",_) $ _ $ t2) v = is_sqrtTerm_in t2 v + | isnorm (Const ("op *",_) $ _ $ t2) v = is_sqrtTerm_in t2 v + | isnorm (Const ("op -",_) $ _ $ _) v = false + | isnorm (Const ("HOL.divide",_) $ t1 $ t2) v = (is_sqrtTerm_in t1 v) orelse + (is_sqrtTerm_in t2 v) + | isnorm (Const ("Root.sqrt",_) $ t1) v = coeff_in t1 v + | isnorm (_ $ t1) v = is_sqrtTerm_in t1 v + | isnorm _ _ = false; + in + isnorm t v + end; + +fun eval_is_rootTerm_in _ _ (p as (Const ("RootEq.is'_rootTerm'_in",_) $ t $ v)) _ = + if is_rootTerm_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_rootTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + +fun eval_is_sqrtTerm_in _ _ (p as (Const ("RootEq.is'_sqrtTerm'_in",_) $ t $ v)) _ = + if is_sqrtTerm_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_sqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + +fun eval_is_normSqrtTerm_in _ _ (p as (Const ("RootEq.is'_normSqrtTerm'_in",_) $ t $ v)) _ = + if is_normSqrtTerm_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_normSqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + +(*-------------------------rulse-------------------------*) +val RootEq_prls = (*15.10.02:just the following order due to subterm evaluation*) + append_rls "RootEq_prls" e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Tools.lhs" ,eval_lhs ""), + Calc ("Tools.rhs" ,eval_rhs ""), + Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""), + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), + Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""), + Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false), + Thm ("or_true",num_str or_true), + Thm ("or_false",num_str or_false) + ]; + +val RootEq_erls = + append_rls "RootEq_erls" Root_erls + [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq) + ]; + +val RootEq_crls = + append_rls "RootEq_crls" Root_crls + [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq) + ]; + +val rooteq_srls = + append_rls "rooteq_srls" e_rls + [Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""), + Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""), + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in "") + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("RootEq_erls",RootEq_erls), (*FIXXXME:del with rls.rls'*) + ("rooteq_srls",rooteq_srls) + ]); + +(*isolate the bound variable in an sqrt equation; 'bdv' is a meta-constant*) + val sqrt_isolate = prep_rls( + Rls {id = "sqrt_isolate", preconds = [], rew_ord = ("termlessI",termlessI), + erls = RootEq_erls, srls = Erls, calc = [], + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), + ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""), + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), + ("sqrt_square_equation_right_6","")],*) + rules = [ + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) + Thm("sqrt_square_equation_both_1",num_str sqrt_square_equation_both_1), + (* (sqrt a + sqrt b = sqrt c + sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *) + Thm("sqrt_square_equation_both_2",num_str sqrt_square_equation_both_2), + (* (sqrt a - sqrt b = sqrt c + sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *) + Thm("sqrt_square_equation_both_3",num_str sqrt_square_equation_both_3), + (* (sqrt a + sqrt b = sqrt c - sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *) + Thm("sqrt_square_equation_both_4",num_str sqrt_square_equation_both_4), + (* (sqrt a - sqrt b = sqrt c - sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *) + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *) + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *) + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *) + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *) + 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 *) + Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *) + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *) + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *) + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *) + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*) + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *) + 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)*) + Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *) + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *) + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1), + (* sqrt(x)=b -> x=b^2 *) + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2), + (* c*sqrt(x)=b -> c^2*x=b^2 *) + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3), + (* c/sqrt(x)=b -> c^2/x=b^2 *) + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4), + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *) + Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5), + (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *) + Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6), + (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *) + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1), + (* a=sqrt(x) ->a^2=x *) + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2), + (* a=c*sqrt(x) ->a^2=c^2*x *) + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3), + (* a=c/sqrt(x) ->a^2=c^2/x *) + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4), + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *) + Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5), + (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *) + Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6) + (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("sqrt_isolate",sqrt_isolate) + ]); +(* -- left 28.08.02--*) +(*isolate the bound variable in an sqrt left equation; 'bdv' is a meta-constant*) + val l_sqrt_isolate = prep_rls( + Rls {id = "l_sqrt_isolate", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = RootEq_erls, srls = Erls, calc = [], + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), + ("sqrt_square_equation_left_6","")],*) + rules = [ + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *) + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *) + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *) + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *) + 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 *) + Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *) + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *) + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1), + (* sqrt(x)=b -> x=b^2 *) + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2), + (* a*sqrt(x)=b -> a^2*x=b^2*) + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3), + (* c/sqrt(x)=b -> c^2/x=b^2 *) + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4), + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *) + Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5), + (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *) + Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6) + (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("l_sqrt_isolate",l_sqrt_isolate) + ]); + +(* -- right 28.8.02--*) +(*isolate the bound variable in an sqrt right equation; 'bdv' is a meta-constant*) + val r_sqrt_isolate = prep_rls( + Rls {id = "r_sqrt_isolate", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = RootEq_erls, srls = Erls, calc = [], + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_right_1",""), + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), + ("sqrt_square_equation_right_6","")],*) + rules = [ + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *) + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *) + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *) + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *) + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *) + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *) + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*) + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *) + 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)*) + Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *) + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *) + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1), + (* a=sqrt(x) ->a^2=x *) + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2), + (* a=c*sqrt(x) ->a^2=c^2*x *) + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3), + (* a=c/sqrt(x) ->a^2=c^2/x *) + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4), + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *) + Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5), + (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *) + Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6) + (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("r_sqrt_isolate",r_sqrt_isolate) + ]); + +val rooteq_simplify = prep_rls( + Rls {id = "rooteq_simplify", + preconds = [], rew_ord = ("termlessI",termlessI), + erls = RootEq_erls, srls = Erls, calc = [], + (*asm_thm = [("sqrt_square_1","")],*) + rules = [Thm ("real_assoc_1",num_str real_assoc_1), (* a+(b+c) = a+b+c *) + Thm ("real_assoc_2",num_str real_assoc_2), (* a*(b*c) = a*b*c *) + Calc ("op +",eval_binop "#add_"), + Calc ("op -",eval_binop "#sub_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + Thm("real_plus_binom_pow2",num_str real_plus_binom_pow2), + Thm("real_minus_binom_pow2",num_str real_minus_binom_pow2), + Thm("realpow_mul",num_str realpow_mul), (* (a * b)^n = a^n * b^n*) + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt b * sqrt c = sqrt(b*c) *) + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a * sqrt a * sqrt b = a * sqrt(a*b) *) + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) = a *) + Thm("sqrt_square_1",num_str sqrt_square_1) (* sqrt a ^^^ 2 = a *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); + ruleset' := overwritelthy thy (!ruleset', + [("rooteq_simplify",rooteq_simplify) + ]); + +(*-------------------------Problem-----------------------*) +(* +(get_pbt ["root","univariate","equation"]); +show_ptyps(); +*) +(* ---------root----------- *) +store_pbt + (prep_pbt RootEq.thy "pbl_equ_univ_root" [] e_pblID + (["root","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_rootTerm_in (v_::real) | \ + \(rhs e_) is_rootTerm_in (v_::real)"]), + ("#Find" ,["solutions v_i_"]) + ], + RootEq_prls, SOME "solve (e_::bool, v_)", + [])); +(* ---------sqrt----------- *) +store_pbt + (prep_pbt RootEq.thy "pbl_equ_univ_root_sq" [] e_pblID + (["sq","root","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ + \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\ + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ + \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]), + ("#Find" ,["solutions v_i_"]) + ], + RootEq_prls, SOME "solve (e_::bool, v_)", + [["RootEq","solve_sq_root_equation"]])); +(* ---------normalize----------- *) +store_pbt + (prep_pbt RootEq.thy "pbl_equ_univ_root_norm" [] e_pblID + (["normalize","root","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ + \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \ + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ + \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]), + ("#Find" ,["solutions v_i_"]) + ], + RootEq_prls, SOME "solve (e_::bool, v_)", + [["RootEq","norm_sq_root_equation"]])); + +(*-------------------------methods-----------------------*) +(* ---- root 20.8.02 ---*) +store_met + (prep_met RootEq.thy "met_rooteq" [] e_metID + (["RootEq"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=RootEq_crls, nrls=norm_Poly(*, + asm_rls=[],asm_thm=[]*)}, "empty_script")); +(*-- normalize 20.10.02 --*) +store_met + (prep_met RootEq.thy "met_rooteq_norm" [] e_metID + (["RootEq","norm_sq_root_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ + \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \ + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ + \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=RootEq_erls, + srls=e_rls, + prls=RootEq_prls, + calc=[], + crls=RootEq_crls, nrls=norm_Poly(*, + asm_rls=[], + asm_thm=[("sqrt_square_1","")]*)}, + "Script Norm_sq_root_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Repeat(Try (Rewrite makex1_x False))) @@ \ + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ + \ (Try (Rewrite_Set rooteq_simplify True)) @@ \ + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ + \ (Try (Rewrite_Set rooteq_simplify True))) e_ \ + \ in ((SubProblem (RootEq_,[univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_])))" + )); + +store_met + (prep_met RootEq.thy "met_rooteq_sq" [] e_metID + (["RootEq","solve_sq_root_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\ + \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\ + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\ + \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=RootEq_erls, + srls = rooteq_srls, + prls = RootEq_prls, + calc = [], + crls=RootEq_crls, nrls=norm_Poly(*, + asm_rls = [], + asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""), + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), + ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""), + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), + ("sqrt_square_equation_right_6","")]*)}, +"Script Solve_sq_root_equation (e_::bool) (v_::real) = \ +\(let e_ = \ +\ ((Try (Rewrite_Set_Inst [(bdv,v_::real)] sqrt_isolate True)) @@ \ +\ (Try (Rewrite_Set rooteq_simplify True)) @@ \ +\ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ +\ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ +\ (Try (Rewrite_Set rooteq_simplify True))) e_;\ +\ (L_::bool list) = \ +\ (if (((lhs e_) is_sqrtTerm_in v_) | ((rhs e_) is_sqrtTerm_in v_))\ +\ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ +\ [no_met]) [bool_ e_, real_ v_]) \ +\ else (SubProblem (RootEq_,[univariate,equation], \ +\ [no_met]) [bool_ e_, real_ v_])) \ +\ in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +(*-- right 28.08.02 --*) +store_met + (prep_met RootEq.thy "met_rooteq_sq_right" [] e_metID + (["RootEq","solve_right_sq_root_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(rhs e_) is_sqrtTerm_in v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=RootEq_erls, + srls=e_rls, + prls=RootEq_prls, + calc=[], + crls=RootEq_crls, nrls=norm_Poly(*, + asm_rls=[], + asm_thm=[("sqrt_square_1",""),("sqrt_square_1",""),("sqrt_square_equation_right_1",""), + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""), + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""), + ("sqrt_square_equation_right_6","")]*)}, + "Script Solve_right_sq_root_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] r_sqrt_isolate False)) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False))) e_\ + \ in if ((rhs e_) is_sqrtTerm_in v_) \ + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_]) \ + \ else ((SubProblem (RootEq_,[univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_])))" + )); + +(*-- left 28.08.02 --*) +store_met + (prep_met RootEq.thy "met_rooteq_sq_left" [] e_metID + (["RootEq","solve_left_sq_root_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(lhs e_) is_sqrtTerm_in v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=RootEq_erls, + srls=e_rls, + prls=RootEq_prls, + calc=[], + crls=RootEq_crls, nrls=norm_Poly(*, + asm_rls=[], + asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_left_1",""), + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""), + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""), + ("sqrt_square_equation_left_6","")]*)}, + "Script Solve_left_sq_root_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] l_sqrt_isolate False)) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \ + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False))) e_\ + \ in if ((lhs e_) is_sqrtTerm_in v_) \ + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_]) \ + \ else ((SubProblem (RootEq_,[univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_])))" + )); + +calclist':= overwritel (!calclist', + [("is_rootTerm_in", ("RootEq.is'_rootTerm'_in", + eval_is_rootTerm_in"")), + ("is_sqrtTerm_in", ("RootEq.is'_sqrtTerm'_in", + eval_is_sqrtTerm_in"")), + ("is_normSqrtTerm_in", ("RootEq.is_normSqrtTerm_in", + eval_is_normSqrtTerm_in"")) + ]);(*("", ("", "")),*) +"******* RootEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootEq.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootEq.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,142 @@ +(*.(c) by Richard Lang, 2003 .*) +(* collecting all knowledge for Root Equations + created by: rlang + date: 02.08 + changed by: rlang + last change by: rlang + date: 02.11.14 +*) +(* use"../knowledge/RootEq.ML"; + use"knowledge/RootEq.ML"; + use"RootEq.ML"; + + remove_thy"RootEq"; + use_thy"Isac"; + + use"ROOT.ML"; + cd"knowledge"; + *) + +RootEq = Root + + +(*-------------------- consts------------------------------------------------*) +consts + (*-------------------------root-----------------------*) + is'_rootTerm'_in :: [real, real] => bool ("_ is'_rootTerm'_in _") + is'_sqrtTerm'_in :: [real, real] => bool ("_ is'_sqrtTerm'_in _") + is'_normSqrtTerm'_in :: [real, real] => bool ("_ is'_normSqrtTerm'_in _") + (*----------------------scripts-----------------------*) + Norm'_sq'_root'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Norm'_sq'_root'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_sq'_root'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_sq'_root'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_left'_sq'_root'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_left'_sq'_root'_equation (_ _ =))// \ + \ (_))" 9) + Solve'_right'_sq'_root'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_right'_sq'_root'_equation (_ _ =))// \ + \ (_))" 9) + +(*-------------------- rules------------------------------------------------*) +rules + +(* normalize *) + makex1_x + "a^^^1 = a" + real_assoc_1 + "a+(b+c) = a+b+c" + real_assoc_2 + "a*(b*c) = a*b*c" + + (* simplification of root*) + sqrt_square_1 + "[|0 <= a|] ==> (sqrt a)^^^2 = a" + sqrt_square_2 + "sqrt (a ^^^ 2) = a" + sqrt_times_root_1 + "sqrt a * sqrt b = sqrt(a*b)" + sqrt_times_root_2 + "a * sqrt b * sqrt c = a * sqrt(b*c)" + + (* isolate one root on the LEFT or RIGHT hand side of the equation *) + sqrt_isolate_l_add1 + "[|bdv occurs_in c|] ==> (a + b*sqrt(c) = d) = (b * sqrt(c) = d+ (-1) * a)" + sqrt_isolate_l_add2 + "[|bdv occurs_in c|] ==>(a + sqrt(c) = d) = ((sqrt(c) = d+ (-1) * a))" + sqrt_isolate_l_add3 + "[|bdv occurs_in c|] ==> (a + b*(e/sqrt(c)) = d) = (b * (e/sqrt(c)) = d+ (-1) * a)" + sqrt_isolate_l_add4 + "[|bdv occurs_in c|] ==>(a + b/(f*sqrt(c)) = d) = (b / (f*sqrt(c)) = d+ (-1) * a)" + sqrt_isolate_l_add5 + "[|bdv occurs_in c|] ==> (a + b*(e/(f*sqrt(c))) = d) = (b * (e/(f*sqrt(c))) = d+ (-1) * a)" + sqrt_isolate_l_add6 + "[|bdv occurs_in c|] ==>(a + b/sqrt(c) = d) = (b / sqrt(c) = d+ (-1) * a)" + sqrt_isolate_r_add1 + "[|bdv occurs_in f|] ==>(a = d + e*sqrt(f)) = (a + (-1) * d = e*sqrt(f))" + sqrt_isolate_r_add2 + "[|bdv occurs_in f|] ==>(a = d + sqrt(f)) = (a + (-1) * d = sqrt(f))" + (* small hack: thm 3,5,6 are not needed if rootnormalize is well done*) + sqrt_isolate_r_add3 + "[|bdv occurs_in f|] ==>(a = d + e*(g/sqrt(f))) = (a + (-1) * d = e*(g/sqrt(f)))" + sqrt_isolate_r_add4 + "[|bdv occurs_in f|] ==>(a = d + g/sqrt(f)) = (a + (-1) * d = g/sqrt(f))" + sqrt_isolate_r_add5 + "[|bdv occurs_in f|] ==>(a = d + e*(g/(h*sqrt(f)))) = (a + (-1) * d = e*(g/(h*sqrt(f))))" + sqrt_isolate_r_add6 + "[|bdv occurs_in f|] ==>(a = d + g/(h*sqrt(f))) = (a + (-1) * d = g/(h*sqrt(f)))" + + (* eliminate isolates sqrt *) + sqrt_square_equation_both_1 + "[|bdv occurs_in b; bdv occurs_in d|] ==> + ( (sqrt a + sqrt b = sqrt c + sqrt d) = + (a+2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))" + sqrt_square_equation_both_2 + "[|bdv occurs_in b; bdv occurs_in d|] ==> + ( (sqrt a - sqrt b = sqrt c + sqrt d) = + (a - 2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))" + sqrt_square_equation_both_3 + "[|bdv occurs_in b; bdv occurs_in d|] ==> + ( (sqrt a + sqrt b = sqrt c - sqrt d) = + (a + 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))" + sqrt_square_equation_both_4 + "[|bdv occurs_in b; bdv occurs_in d|] ==> + ( (sqrt a - sqrt b = sqrt c - sqrt d) = + (a - 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))" + sqrt_square_equation_left_1 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (sqrt (a) = b) = (a = (b^^^2)))" + sqrt_square_equation_left_2 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( (c*sqrt(a) = b) = (c^^^2*a = b^^^2))" + sqrt_square_equation_left_3 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( c/sqrt(a) = b) = (c^^^2 / a = b^^^2)" + (* small hack: thm 4-6 are not needed if rootnormalize is well done*) + sqrt_square_equation_left_4 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( (c*(d/sqrt (a)) = b) = (c^^^2*(d^^^2/a) = b^^^2))" + sqrt_square_equation_left_5 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( c/(d*sqrt(a)) = b) = (c^^^2 / (d^^^2*a) = b^^^2)" + sqrt_square_equation_left_6 + "[|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))" + sqrt_square_equation_right_1 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = sqrt (b)) = (a^^^2 = b))" + sqrt_square_equation_right_2 + "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c*sqrt (b)) = ((a^^^2) = c^^^2*b))" + sqrt_square_equation_right_3 + "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c/sqrt (b)) = (a^^^2 = c^^^2/b))" + (* small hack: thm 4-6 are not needed if rootnormalize is well done*) + sqrt_square_equation_right_4 + "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c*(d/sqrt (b))) = ((a^^^2) = c^^^2*(d^^^2/b)))" + sqrt_square_equation_right_5 + "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c/(d*sqrt (b))) = (a^^^2 = c^^^2/(d^^^2*b)))" + sqrt_square_equation_right_6 + "[|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))))" + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootRat.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootRat.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,50 @@ +(*.(c) by Richard Lang, 2003 .*) +(* collecting all knowledge for Root and Rational + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.10.21 +*) +(* use"knowledge/RootRat.ML"; + use"RootRat.ML"; + + use"ROOT.ML"; + cd"knowledge"; + + remove_thy"RootRat"; + use_thy"Isac"; + *) + +"******* RootRat.ML begin *******"; +theory' := overwritel (!theory', [("RootRat.thy",RootRat.thy)]); + +(*-------------------------functions---------------------*) + +(*-------------------------rulse-------------------------*) +val rootrat_erls = + merge_rls "rootrat_erls" Root_erls + (merge_rls "" rational_erls + (append_rls "" e_rls + [])); + +ruleset' := overwritelthy thy (!ruleset', + [("rootrat_erls",rootrat_erls) (*FIXXXME:del with rls.rls'*) + ]); + +(*.calculate numeral groundterms.*) +val calculate_RootRat = + append_rls "calculate_RootRat" calculate_Rational + [Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (* w*(z1.0 + z2.0) = w * z1.0 + w * z2.0 *) + Thm ("real_mult_1",num_str real_mult_1), + (* 1 * z = z *) + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)), + (* "- z1 = -1 * z1" *) + Calc ("Root.sqrt",eval_sqrt "#sqrt_") + ]; +ruleset' := overwritelthy thy (!ruleset', + [("calculate_RootRat",calculate_RootRat)]); + + +"******* RootRat.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootRat.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootRat.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,16 @@ +(*.(c) by Richard Lang, 2003 .*) +(* collecting all knowledge for Root and Rational + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.10.20 +*) + +RootRat = Root + Rational + +(*-------------------- consts------------------------------------------------*) + + +(*-------------------- rules------------------------------------------------*) + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootRatEq.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootRatEq.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,166 @@ +(*.(c) by Richard Lang, 2003 .*) +(* collecting all knowledge for Root and Rational Equations + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.11.04 +*) + +(* use"knowledge/RootRatEq.ML"; + use"RootRatEq.ML"; + + use"ROOT.ML"; + cd"knowledge"; + + remove_thy"RootRatEq"; + use_thy"Isac"; + *) + +"******* RootRatEq.ML begin *******"; +theory' := overwritel (!theory', [("RootRatEq.thy",RootRatEq.thy)]); + +(*-------------------------functions---------------------*) +(* true if denominator contains (sq)root in + or - term + 1/(sqrt(x+3)*(x+4)) -> false; 1/(sqrt(x)+2) -> true + if false then (term)^2 contains no (sq)root *) +fun is_rootRatAddTerm_in t v = + let + fun coeff_in c v = member op = (vars c) v; + fun rootadd (t as (Const ("op +",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse + (is_rootTerm_in t3 v) + | rootadd (t as (Const ("op -",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse + (is_rootTerm_in t3 v) + | rootadd _ _ = false; + fun findrootrat (_ $ _ $ _ $ _) v = raise error("is_rootRatAddTerm_in:") + (* at the moment there is no term like this, but ....*) + | findrootrat (t as (Const ("HOL.divide",_) $ _ $ t3)) v = + if (is_rootTerm_in t3 v) then rootadd t3 v else false + | findrootrat (_ $ t1 $ t2) v = (findrootrat t1 v) orelse (findrootrat t2 v) + | findrootrat (_ $ t1) v = (findrootrat t1 v) + | findrootrat _ _ = false; + in + findrootrat t v + end; + +fun eval_is_rootRatAddTerm_in _ _ (p as (Const ("RootRatEq.is'_rootRatAddTerm'_in",_) $ t $ v)) _ = + if is_rootRatAddTerm_in t v then + SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.true_const))) + else SOME ((term2str p) ^ " = True", + Trueprop $ (mk_equality (p, HOLogic.false_const))) + | eval_is_rootRatAddTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE); + +(*-------------------------rulse-------------------------*) +val RootRatEq_prls = + append_rls "RootRatEq_prls" e_rls + [Calc ("Atools.ident",eval_ident "#ident_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Tools.lhs" ,eval_lhs ""), + Calc ("Tools.rhs" ,eval_rhs ""), + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""), + Calc ("RootRatEq.is'_rootRatAddTerm'_in", eval_is_rootRatAddTerm_in ""), + Calc ("op =",eval_equal "#equal_"), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",num_str and_true), + Thm ("and_false",num_str and_false), + Thm ("or_true",num_str or_true), + Thm ("or_false",num_str or_false) + ]; + + +val RooRatEq_erls = + merge_rls "RooRatEq_erls" rootrat_erls + (merge_rls "" RootEq_erls + (merge_rls "" rateq_erls + (append_rls "" e_rls + []))); + +val RootRatEq_crls = + merge_rls "RootRatEq_crls" rootrat_erls + (merge_rls "" RootEq_erls + (merge_rls "" rateq_erls + (append_rls "" e_rls + []))); + +ruleset' := overwritelthy thy (!ruleset', + [("RooRatEq_erls",RooRatEq_erls) (*FIXXXME:del with rls.rls'*) + ]); + +(* Solves a rootrat Equation *) + val rootrat_solve = prep_rls( + Rls {id = "rootrat_solve", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*) + rules = [ Thm("rootrat_equation_left_1",num_str rootrat_equation_left_1), + (* [|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c )) *) + Thm("rootrat_equation_left_2",num_str rootrat_equation_left_2), + (* [|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c )) *) + Thm("rootrat_equation_right_1",num_str rootrat_equation_right_1), + (* [|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e )) *) + Thm("rootrat_equation_right_2",num_str rootrat_equation_right_2) + (* [|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e )) *) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + }:rls); +ruleset' := overwritelthy thy (!ruleset', + [("rootrat_solve",rootrat_solve) + ]); + +(*-----------------------probleme------------------------*) +(* +(get_pbt ["rat","root","univariate","equation"]); +show_ptyps(); +*) +store_pbt + (prep_pbt RootRatEq.thy "pbl_equ_univ_root_sq_rat" [] e_pblID + (["rat","sq","root","univariate","equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) )| \ + \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]), + ("#Find" ,["solutions v_i_"]) + ], + RootRatEq_prls, SOME "solve (e_::bool, v_)", + [["RootRatEq","elim_rootrat_equation"]])); + +(*-------------------------Methode-----------------------*) +store_met + (prep_met LinEq.thy "met_rootrateq" [] e_metID + (["RootRatEq"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=Atools_erls, nrls=norm_Rational(*, + asm_rls=[],asm_thm=[]*)}, "empty_script")); +(*-- left 20.10.02 --*) +store_met + (prep_met RootRatEq.thy "met_rootrateq_elim" [] e_metID + (["RootRatEq","elim_rootrat_equation"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) ) | \ + \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="termlessI", + rls'=RooRatEq_erls, + srls=e_rls, + prls=RootRatEq_prls, + calc=[], + crls=RootRatEq_crls, nrls=norm_Rational(*, + asm_rls=[], + asm_thm=[]*)}, + "Script Elim_rootrat_equation (e_::bool) (v_::real) = \ + \(let e_ = ((Try (Rewrite_Set expand_rootbinoms False)) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ + \ (Try (Rewrite_Set make_rooteq False)) @@ \ + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \ + \ (Try (Rewrite_Set_Inst [(bdv,v_)] \ + \ rootrat_solve False))) e_ \ + \ in (SubProblem (RootEq_,[univariate,equation], \ + \ [no_met]) [bool_ e_, real_ v_]))" + )); +calclist':= overwritel (!calclist', + [("is_rootRatAddTerm_in", ("RootRatEq.is_rootRatAddTerm_in", + eval_is_rootRatAddTerm_in"")) + ]);(*("", ("", "")),*) +"******* RootRatEq.ML end *******"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/RootRatEq.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/RootRatEq.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,48 @@ +(*.c) by Richard Lang, 2003 .*) +(* collecting all knowledge for Root and Rational Equations + created by: rlang + date: 02.10 + changed by: rlang + last change by: rlang + date: 02.11.04 +*) + +(* use"knowledge/RootRatEq.ML"; + use"RootRatEq.ML"; + + use"ROOT.ML"; + cd"knowledge"; + + remove_thy"RootRatEq"; + use_thy"Isac"; + *) + +RootRatEq = RootEq + RatEq + RootRat + + +(*-------------------- consts-----------------------------------------------*) +consts + + is'_rootRatAddTerm'_in :: [real, real] => bool ("_ is'_rootRatAddTerm'_in _") (*RL DA*) + +(*---------scripts--------------------------*) + Elim'_rootrat'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Elim'_rootrat'_equation (_ _ =))// \ + \ (_))" 9) + (*-------------------- rules------------------------------------------------*) +rules + + (* eliminate ratRootTerm *) + rootrat_equation_left_1 + "[|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c ))" + rootrat_equation_left_2 + "[|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c ))" + rootrat_equation_right_2 + "[|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e ))" + rootrat_equation_right_1 + "[|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e ))" + + + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Simplify.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Simplify.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,76 @@ +(* simplification of terms + author: Walther Neuper 050912 + (c) due to copyright terms + +use"Knowledge/Simplify.ML"; +use"Simplify.ML"; +*) + + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("Simplify.thy",Simplify.thy)]); + +(** problems **) + +store_pbt + (prep_pbt Simplify.thy "pbl_simp" [] e_pblID + (["simplification"], + [("#Given" ,["term t_"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "Simplify t_", + [])); + +store_pbt + (prep_pbt Simplify.thy "pbl_vereinfache" [] e_pblID + (["vereinfachen"], + [("#Given" ,["term t_"]), + ("#Find" ,["normalform n_"]) + ], + append_rls "e_rls" e_rls [(*for preds in where_*)], + SOME "Vereinfache t_", + [])); + +(** methods **) + +store_met + (prep_met Simplify.thy "met_simp" [] e_metID + (["simplification"], + [("#Given" ,["term t_"]), + ("#Find" ,["normalform n_"]) + ], + {rew_ord'="tless_true", + rls'= e_rls, + calc = [], + srls = e_rls, + prls=e_rls, + crls = e_rls, nrls = e_rls}, + "empty_script" + )); + +(** CAS-command **) + +(*.function for handling the cas-input "Simplify (2*a + 3*a)": + make a model which is already in ptree-internal format.*) +(* val (h,argl) = strip_comb (str2term "Simplify (2*a + 3*a)"); + val (h,argl) = strip_comb ((term_of o the o (parse thy)) + "Simplify (2*a + 3*a)"); + *) +fun argl2dtss t = + [((term_of o the o (parse thy)) "term", t), + ((term_of o the o (parse thy)) "normalform", + [(term_of o the o (parse thy)) "N"]) + ] + | argl2dtss _ = raise error "Simplify.ML: wrong argument for argl2dtss"; + +castab := +overwritel (!castab, + [((term_of o the o (parse thy)) "Simplify", + (("Isac.thy", ["simplification"], ["no_met"]), + argl2dtss)), + ((term_of o the o (parse thy)) "Vereinfache", + (("Isac.thy", ["vereinfachen"], ["no_met"]), + argl2dtss)) + ]); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Simplify.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Simplify.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,29 @@ +(* simplification of terms + author: Walther Neuper 050912 + (c) due to copyright terms + +remove_thy"Simplify"; +use_thy"~/proto2/isac/src/sml/Knowledge/Simplify"; + +use_thy_only"~/proto2/isac/src/sml/Knowledge/Simplify"; +use_thy"~/proto2/isac/src/sml/Knowledge/Isac"; +*) + +Simplify = Atools + + +consts + + (*descriptions in the related problem*) + term :: real => una + normalform :: real => una + + (*the CAS-command*) + Simplify :: "real => real" (*"Simplify (1+2a+3+4a)*) + Vereinfache :: "real => real" (*"Vereinfache (1+2a+3+4a)*) + + (*Script-name*) + SimplifyScript :: "[real, real] => real" + ("((Script SimplifyScript (_ =))// (_))" 9) + + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Test.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Test.ML Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1301 @@ +(* SML functions for rational arithmetic + WN.22.10.99 + use"../knowledge/Test.ML"; + use"Knowledge/Test.ML"; + use"Test.ML"; + *) + + +(** interface isabelle -- isac **) + +theory' := overwritel (!theory', [("Test.thy",Test.thy)]); + +(** evaluation of numerals and predicates **) + +(*does a term contain a root ?*) +fun eval_root_free (thmid:string) _ (t as (Const(op0,t0) $ arg)) thy = + if strip_thy op0 <> "is'_root'_free" + then raise error ("eval_root_free: wrong "^op0) + else if const_in (strip_thy op0) arg + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, false_as_term))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, true_as_term))) + | eval_root_free _ _ _ _ = NONE; + +(*does a term contain a root ?*) +fun eval_contains_root (thmid:string) _ + (t as (Const("Test.contains'_root",t0) $ arg)) thy = + if member op = (ids_of arg) "sqrt" + then SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, true_as_term))) + else SOME (mk_thmid thmid "" + ((Syntax.string_of_term (thy2ctxt thy)) arg) "", + Trueprop $ (mk_equality (t, false_as_term))) + | eval_contains_root _ _ _ _ = NONE; + +calclist':= overwritel (!calclist', + [("is_root_free", ("Test.is'_root'_free", + eval_root_free"#is_root_free_")), + ("contains_root", ("Test.contains'_root", + eval_contains_root"#contains_root_")) + ]); + +(** term order **) +fun term_order (_:subst) tu = (term_ordI [] tu = LESS); + +(** rule sets **) + +val testerls = + Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI), + erls = e_rls, srls = Erls, + calc = [], + rules = [Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + Thm ("and_commute",num_str and_commute), + Thm ("or_commute",num_str or_commute), + + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Tools.matches",eval_matches ""), + + Calc ("op +",eval_binop "#add_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_")], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +(*.for evaluation of conditions in rewrite rules.*) +(*FIXXXXXXME 10.8.02: handle like _simplify*) +val tval_rls = + Rls{id = "tval_rls", preconds = [], + rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")), + erls=testerls,srls = e_rls, + calc=[], + rules = [Thm ("refl",num_str refl), + Thm ("le_refl",num_str le_refl), + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le), + Thm ("not_true",num_str not_true), + Thm ("not_false",num_str not_false), + Thm ("and_true",and_true), + Thm ("and_false",and_false), + Thm ("or_true",or_true), + Thm ("or_false",or_false), + Thm ("and_commute",num_str and_commute), + Thm ("or_commute",num_str or_commute), + + Thm ("real_diff_minus",num_str real_diff_minus), + + Thm ("root_ge0",num_str root_ge0), + Thm ("root_add_ge0",num_str root_add_ge0), + Thm ("root_ge0_1",num_str root_ge0_1), + Thm ("root_ge0_2",num_str root_ge0_2), + + Calc ("Atools.is'_const",eval_const "#is_const_"), + Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_"), + Calc ("Tools.matches",eval_matches ""), + Calc ("Test.contains'_root", + eval_contains_root"#contains_root_"), + + Calc ("op +",eval_binop "#add_"), + Calc ("op *",eval_binop "#mult_"), + Calc ("Root.sqrt",eval_sqrt "#sqrt_"), + Calc ("Atools.pow" ,eval_binop "#power_"), + + Calc ("op <",eval_equ "#less_"), + Calc ("op <=",eval_equ "#less_equal_"), + + Calc ("Atools.ident",eval_ident "#ident_")], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + + +ruleset' := overwritelthy thy (!ruleset', + [("testerls", prep_rls testerls) + ]); + + +(*make () dissappear*) +val rearrange_assoc = + Rls{id = "rearrange_assoc", preconds = [], + rew_ord = ("e_rew_ord",e_rew_ord), + erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*) + rules = + [Thm ("sym_radd_assoc",num_str (radd_assoc RS sym)), + Thm ("sym_rmult_assoc",num_str (rmult_assoc RS sym))], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +val ac_plus_times = + Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order), + erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*) + rules = + [Thm ("radd_commute",radd_commute), + Thm ("radd_left_commute",radd_left_commute), + Thm ("radd_assoc",radd_assoc), + Thm ("rmult_commute",rmult_commute), + Thm ("rmult_left_commute",rmult_left_commute), + Thm ("rmult_assoc",rmult_assoc)], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +(*todo: replace by Rewrite("rnorm_equation_add",num_str rnorm_equation_add)*) +val norm_equation = + Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), + erls = tval_rls, srls = e_rls, calc = [], (*asm_thm=[],*) + rules = [Thm ("rnorm_equation_add",num_str rnorm_equation_add) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +(** rule sets **) + +val STest_simplify = (* vv--- not changed to real by parse*) + "Script STest_simplify (t_::'z) = \ + \(Repeat\ + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + \ (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@ \ + \ (Try (Repeat (Rewrite rdistr_right_assoc False))) @@ \ + \ (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@\ + \ (Try (Repeat (Rewrite rdistr_div_right False))) @@ \ + \ (Try (Repeat (Rewrite rbinom_power_2 False))) @@ \ + + \ (Try (Repeat (Rewrite radd_commute False))) @@ \ + \ (Try (Repeat (Rewrite radd_left_commute False))) @@ \ + \ (Try (Repeat (Rewrite radd_assoc False))) @@ \ + \ (Try (Repeat (Rewrite rmult_commute False))) @@ \ + \ (Try (Repeat (Rewrite rmult_left_commute False))) @@ \ + \ (Try (Repeat (Rewrite rmult_assoc False))) @@ \ + + \ (Try (Repeat (Rewrite radd_real_const_eq False))) @@ \ + \ (Try (Repeat (Rewrite radd_real_const False))) @@ \ + \ (Try (Repeat (Calculate plus))) @@ \ + \ (Try (Repeat (Calculate times))) @@ \ + \ (Try (Repeat (Calculate divide_))) @@\ + \ (Try (Repeat (Calculate power_))) @@ \ + + \ (Try (Repeat (Rewrite rcollect_right False))) @@ \ + \ (Try (Repeat (Rewrite rcollect_one_left False))) @@ \ + \ (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@ \ + \ (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@ \ + + \ (Try (Repeat (Rewrite rshift_nominator False))) @@ \ + \ (Try (Repeat (Rewrite rcancel_den False))) @@ \ + \ (Try (Repeat (Rewrite rroot_square_inv False))) @@ \ + \ (Try (Repeat (Rewrite rroot_times_root False))) @@ \ + \ (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@ \ + \ (Try (Repeat (Rewrite rsqare False))) @@ \ + \ (Try (Repeat (Rewrite power_1 False))) @@ \ + \ (Try (Repeat (Rewrite rtwo_of_the_same False))) @@ \ + \ (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@ \ + + \ (Try (Repeat (Rewrite rmult_1 False))) @@ \ + \ (Try (Repeat (Rewrite rmult_1_right False))) @@ \ + \ (Try (Repeat (Rewrite rmult_0 False))) @@ \ + \ (Try (Repeat (Rewrite rmult_0_right False))) @@ \ + \ (Try (Repeat (Rewrite radd_0 False))) @@ \ + \ (Try (Repeat (Rewrite radd_0_right False)))) \ + \ t_)"; + + +(* expects * distributed over + *) +val Test_simplify = + Rls{id = "Test_simplify", preconds = [], + rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")), + erls = tval_rls, srls = e_rls, + calc=[(*since 040209 filled by prep_rls*)], + (*asm_thm = [],*) + rules = [ + Thm ("real_diff_minus",num_str real_diff_minus), + Thm ("radd_mult_distrib2",num_str radd_mult_distrib2), + Thm ("rdistr_right_assoc",num_str rdistr_right_assoc), + Thm ("rdistr_right_assoc_p",num_str rdistr_right_assoc_p), + Thm ("rdistr_div_right",num_str rdistr_div_right), + Thm ("rbinom_power_2",num_str rbinom_power_2), + + Thm ("radd_commute",num_str radd_commute), + Thm ("radd_left_commute",num_str radd_left_commute), + Thm ("radd_assoc",num_str radd_assoc), + Thm ("rmult_commute",num_str rmult_commute), + Thm ("rmult_left_commute",num_str rmult_left_commute), + Thm ("rmult_assoc",num_str rmult_assoc), + + Thm ("radd_real_const_eq",num_str radd_real_const_eq), + Thm ("radd_real_const",num_str radd_real_const), + (* these 2 rules are invers to distr_div_right wrt. termination. + thus they MUST be done IMMEDIATELY before calc *) + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("HOL.divide", eval_cancel "#divide_"), + Calc ("Atools.pow", eval_binop "#power_"), + + Thm ("rcollect_right",num_str rcollect_right), + Thm ("rcollect_one_left",num_str rcollect_one_left), + Thm ("rcollect_one_left_assoc",num_str rcollect_one_left_assoc), + Thm ("rcollect_one_left_assoc_p",num_str rcollect_one_left_assoc_p), + + Thm ("rshift_nominator",num_str rshift_nominator), + Thm ("rcancel_den",num_str rcancel_den), + Thm ("rroot_square_inv",num_str rroot_square_inv), + Thm ("rroot_times_root",num_str rroot_times_root), + Thm ("rroot_times_root_assoc_p",num_str rroot_times_root_assoc_p), + Thm ("rsqare",num_str rsqare), + Thm ("power_1",num_str power_1), + Thm ("rtwo_of_the_same",num_str rtwo_of_the_same), + Thm ("rtwo_of_the_same_assoc_p",num_str rtwo_of_the_same_assoc_p), + + Thm ("rmult_1",num_str rmult_1), + Thm ("rmult_1_right",num_str rmult_1_right), + Thm ("rmult_0",num_str rmult_0), + Thm ("rmult_0_right",num_str rmult_0_right), + Thm ("radd_0",num_str radd_0), + Thm ("radd_0_right",num_str radd_0_right) + ], + scr = Script ((term_of o the o (parse thy)) "empty_script") + (*since 040209 filled by prep_rls: STest_simplify*) + }:rls; + + + + + +(** rule sets **) + + + +(*isolate the root in a root-equation*) +val isolate_root = + Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), + erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *) + rules = [Thm ("rroot_to_lhs",num_str rroot_to_lhs), + Thm ("rroot_to_lhs_mult",num_str rroot_to_lhs_mult), + Thm ("rroot_to_lhs_add_mult",num_str rroot_to_lhs_add_mult), + Thm ("risolate_root_add",num_str risolate_root_add), + Thm ("risolate_root_mult",num_str risolate_root_mult), + Thm ("risolate_root_div",num_str risolate_root_div) ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + +(*isolate the bound variable in an equation; 'bdv' is a meta-constant*) +val isolate_bdv = + Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord), + erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *) + rules = + [Thm ("risolate_bdv_add",num_str risolate_bdv_add), + Thm ("risolate_bdv_mult_add",num_str risolate_bdv_mult_add), + Thm ("risolate_bdv_mult",num_str risolate_bdv_mult), + Thm ("mult_square",num_str mult_square), + Thm ("constant_square",num_str constant_square), + Thm ("constant_mult_square",num_str constant_mult_square) + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + + + + +(* association list for calculate_, calculate + "op +" etc. not usable in scripts *) +val calclist = + [ + (*as Tools.ML*) + ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")), + ("matches",("Tools.matches",eval_matches "#matches_")), + ("lhs" ,("Tools.lhs" ,eval_lhs "")), + (*aus Atools.ML*) + ("PLUS" ,("op +" ,eval_binop "#add_")), + ("TIMES" ,("op *" ,eval_binop "#mult_")), + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")), + ("POWER" ,("Atools.pow" ,eval_binop "#power_")), + ("is_const",("Atools.is'_const",eval_const "#is_const_")), + ("le" ,("op <" ,eval_equ "#less_")), + ("leq" ,("op <=" ,eval_equ "#less_equal_")), + ("ident" ,("Atools.ident",eval_ident "#ident_")), + (*von hier (ehem.SqRoot*) + ("sqrt" ,("Root.sqrt" ,eval_sqrt "#sqrt_")), + ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_")), + ("Test.contains_root",("contains'_root", + eval_contains_root"#contains_root_")) + ]; + +ruleset' := overwritelthy thy (!ruleset', + [("Test_simplify", prep_rls Test_simplify), + ("tval_rls", prep_rls tval_rls), + ("isolate_root", prep_rls isolate_root), + ("isolate_bdv", prep_rls isolate_bdv), + ("matches", + prep_rls (append_rls "matches" testerls + [Calc ("Tools.matches",eval_matches "#matches_")])) + ]); + +(** problem types **) +store_pbt + (prep_pbt Test.thy "pbl_test" [] e_pblID + (["test"], + [], + e_rls, NONE, [])); +store_pbt + (prep_pbt Test.thy "pbl_test_equ" [] e_pblID + (["equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + assoc_rls "matches", + SOME "solve (e_::bool, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni" [] e_pblID + (["univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + assoc_rls "matches", + SOME "solve (e_::bool, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_lin" [] e_pblID + (["linear","univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(matches ( v_ = 0) e_) | (matches ( ?b*v_ = 0) e_) |\ + \(matches (?a+v_ = 0) e_) | (matches (?a+?b*v_ = 0) e_) "]), + ("#Find" ,["solutions v_i_"]) + ], + assoc_rls "matches", + SOME "solve (e_::bool, v_)", [["Test","solve_linear"]])); + +(*25.8.01 ------ +store_pbt + (prep_pbt Test.thy + (["Test.thy"], + [("#Given" ,"boolTestGiven g_"), + ("#Find" ,"boolTestFind f_") + ], + [])); + +store_pbt + (prep_pbt Test.thy + (["testeq","Test.thy"], + [("#Given" ,"boolTestGiven g_"), + ("#Find" ,"boolTestFind f_") + ], + [])); + + +val ttt = (term_of o the o (parse Isac.thy)) "(matches ( v_ = 0) e_)"; + + ------ 25.8.01*) + + +(** methods **) +store_met + (prep_met Diff.thy "met_test" [] e_metID + (["Test"], + [], + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls, + crls=Atools_erls, nrls=e_rls(*, + asm_rls=[],asm_thm=[]*)}, "empty_script")); +(* +store_met + (prep_met Script.thy + (e_metID,(*empty method*) + [], + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], + asm_rls=[],asm_thm=[]}, + "Undef"));*) +store_met + (prep_met Test.thy "met_test_solvelin" [] e_metID + (["Test","solve_linear"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["matches (?a = ?b) e_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls, + prls=assoc_rls "matches", + calc=[], + crls=tval_rls, nrls=Test_simplify}, + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ =\ + \ Repeat\ + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Rewrite_Set Test_simplify False))) e_\ + \ in [e_::bool])" + ) +(*, prep_met Test.thy (*test for equations*) + (["Test","testeq"]:metID, + [("#Given" ,["boolTestGiven g_"]), + ("#Find" ,["boolTestFind f_"]) + ], + {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[], + asm_thm=[("square_equation_left","")]}, + "Script Testeq (eq_::bool) = \ + \Repeat \ + \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False eq_)); \ + \ e_ = Try (Repeat (Rewrite square_equation_left True e_)); \ + \ e_ = Try (Repeat (Rewrite rmult_0 False e_)) \ + \ in e_) Until (is_root_free e_)" (*deleted*) + ) +, ---------27.4.02*) +); + + + + +ruleset' := overwritelthy thy (!ruleset', + [("norm_equation", prep_rls norm_equation), + ("ac_plus_times", prep_rls ac_plus_times), + ("rearrange_assoc", prep_rls rearrange_assoc) + ]); + + +fun bin_o (Const (op_,(Type ("fun", + [Type (s2,[]),Type ("fun", + [Type (s4,tl4),Type (s5,tl5)])])))) = + if (s2=s4)andalso(s4=s5)then[op_]else[] + | bin_o _ = []; + +fun bin_op (t1 $ t2) = union op = (bin_op t1) (bin_op t2) + | bin_op t = bin_o t; +fun is_bin_op t = ((bin_op t)<>[]); + +fun bin_op_arg1 ((Const (op_,(Type ("fun", + [Type (s2,[]),Type ("fun", + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = + arg1; +fun bin_op_arg2 ((Const (op_,(Type ("fun", + [Type (s2,[]),Type ("fun", + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) = + arg2; + + +exception NO_EQUATION_TERM; +fun is_equation ((Const ("op =",(Type ("fun", + [Type (_,[]),Type ("fun", + [Type (_,[]),Type ("bool",[])])])))) $ _ $ _) + = true + | is_equation _ = false; +fun equ_lhs ((Const ("op =",(Type ("fun", + [Type (_,[]),Type ("fun", + [Type (_,[]),Type ("bool",[])])])))) $ l $ r) + = l + | equ_lhs _ = raise NO_EQUATION_TERM; +fun equ_rhs ((Const ("op =",(Type ("fun", + [Type (_,[]),Type ("fun", + [Type (_,[]),Type ("bool",[])])])))) $ l $ r) + = r + | equ_rhs _ = raise NO_EQUATION_TERM; + + +fun atom (Const (_,Type (_,[]))) = true + | atom (Free (_,Type (_,[]))) = true + | atom (Var (_,Type (_,[]))) = true +(*| atom (_ (_,"?DUMMY" )) = true ..ML-error *) + | atom((Const ("Bin.integ_of_bin",_)) $ _) = true + | atom _ = false; + +fun varids (Const (s,Type (_,[]))) = [strip_thy s] + | varids (Free (s,Type (_,[]))) = if is_no s then [] + else [strip_thy s] + | varids (Var((s,_),Type (_,[]))) = [strip_thy s] +(*| varids (_ (s,"?DUMMY" )) = ..ML-error *) + | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*) + | varids (Abs(a,T,t)) = union op = [a] (varids t) + | varids (t1 $ t2) = union op = (varids t1) (varids t2) + | varids _ = []; +(*> val t = term_of (hd (parse Diophant.thy "x")); +val t = Free ("x","?DUMMY") : term +> varids t; +val it = [] : string list [] !!! *) + + +fun bin_ops_only ((Const op_) $ t1 $ t2) = + if(is_bin_op (Const op_)) + then(bin_ops_only t1)andalso(bin_ops_only t2) + else false + | bin_ops_only t = + if atom t then true else bin_ops_only t; + +fun polynomial opl t bdVar = (* bdVar TODO *) + subset op = (bin_op t, opl) andalso (bin_ops_only t); + +fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *) + andalso polynomial opl (equ_lhs t) bdVar + andalso polynomial opl (equ_rhs t) bdVar + andalso (subset op = (varids bdVar, varids (equ_lhs t)) orelse + subset op = (varids bdVar, varids (equ_lhs t))); + +(*fun max is = + let fun max_ m [] = m + | max_ m (i::is) = if m max [1,5,3,7,4,2]; +val it = 7 : int *) + +fun max (a,b) = if a < b then b else a; + +fun degree addl mul bdVar t = +let +fun deg _ _ v (Const (s,Type (_,[]))) = if v=strip_thy s then 1 else 0 + | deg _ _ v (Free (s,Type (_,[]))) = if v=strip_thy s then 1 else 0 + | deg _ _ v (Var((s,_),Type (_,[]))) = if v=strip_thy s then 1 else 0 +(*| deg _ _ v (_ (s,"?DUMMY" )) = ..ML-error *) + | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0 + | deg addl mul v (h $ t1 $ t2) = + if subset op = (bin_op h, addl) + then max (deg addl mul v t1 ,deg addl mul v t2) + else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2) +in if polynomial (addl @ [mul]) t bdVar + then SOME (deg addl mul (id_of bdVar) t) else (NONE:int option) +end; +fun degree_ addl mul bdVar t = (* do not export *) + let fun opt (SOME i)= i + | opt NONE = 0 +in opt (degree addl mul bdVar t) end; + + +fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2; + +fun linear_equ addl mul bdVar t = + if is_equation t + then let val degl = degree_ addl mul bdVar (equ_lhs t); + val degr = degree_ addl mul bdVar (equ_rhs t) + in if (degl>0 orelse degr>0)andalso max(degl,degr)<2 + then true else false + end + else false; +(* strip_thy op_ before *) +fun is_div_op (dv,(Const (op_,(Type ("fun", + [Type (s2,[]),Type ("fun", + [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_) + | is_div_op _ = false; + +fun is_denom bdVar div_op t = + let fun is bool[v]dv (Const (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false) + | is bool[v]dv (Free (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false) + | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false) + | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false + | is bool[v]dv (h$n$d) = + if is_div_op(dv,h) + then (is false[v]dv n)orelse(is true[v]dv d) + else (is bool [v]dv n)orelse(is bool[v]dv d) +in is false (varids bdVar) (strip_thy div_op) t end; + + +fun rational t div_op bdVar = + is_denom bdVar div_op t andalso bin_ops_only t; + + + +(** problem types **) + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_plain2" [] e_pblID + (["plain_square","univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\ + \(matches ( ?b*v_ ^^^2 = 0) e_) |\ + \(matches (?a + v_ ^^^2 = 0) e_) |\ + \(matches ( v_ ^^^2 = 0) e_)"]), + ("#Find" ,["solutions v_i_"]) + ], + assoc_rls "matches", + SOME "solve (e_::bool, v_)", [["Test","solve_plain_square"]])); +(* + val e_ = (term_of o the o (parse thy)) "e_::bool"; + val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0"; + val env = [(e_,ve)]; + + val pre = (term_of o the o (parse thy)) + "(matches (a + b*v_ ^^^2 = 0, e_::bool)) |\ + \(matches ( b*v_ ^^^2 = 0, e_::bool)) |\ + \(matches (a + v_ ^^^2 = 0, e_::bool)) |\ + \(matches ( v_ ^^^2 = 0, e_::bool))"; + val prei = subst_atomic env pre; + val cpre = (cterm_of thy) prei; + + val SOME (ct,_) = rewrite_set_ thy false tval_rls cpre; +val ct = "True | False | False | False" : cterm + +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct; +val ct = "True" : cterm + +*) + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_poly" [] e_pblID + (["polynomial","univariate","equation","test"], + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), + ("#Where" ,["False"]), + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (e_::bool, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_poly_deg2" [] e_pblID + (["degree_two","polynomial","univariate","equation","test"], + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_poly_deg2_pq" [] e_pblID + (["pq_formula","degree_two","polynomial","univariate","equation","test"], + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_poly_deg2_abc" [] e_pblID + (["abc_formula","degree_two","polynomial","univariate","equation","test"], + [("#Given" ,["equality (a_ * x ^^^2 + b_ * x + c_ = 0)","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (a_ * x ^^^2 + b_ * x + c_ = 0, v_)", [])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_root" [] e_pblID + (["squareroot","univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["contains_root (e_::bool)"]), + ("#Find" ,["solutions v_i_"]) + ], + append_rls "contains_root" e_rls [Calc ("Test.contains'_root", + eval_contains_root "#contains_root_")], + SOME "solve (e_::bool, v_)", [["Test","square_equation"]])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_norm" [] e_pblID + (["normalize","univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,[]), + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (e_::bool, v_)", [["Test","norm_univar_equation"]])); + +store_pbt + (prep_pbt Test.thy "pbl_test_uni_roottest" [] e_pblID + (["sqroot-test","univariate","equation","test"], + [("#Given" ,["equality e_","solveFor v_"]), + (*("#Where" ,["contains_root (e_::bool)"]),*) + ("#Find" ,["solutions v_i_"]) + ], + e_rls, SOME "solve (e_::bool, v_)", [])); + +(* +(#ppc o get_pbt) ["sqroot-test","univariate","equation"]; + *) + + +store_met + (prep_met Test.thy "met_test_sqrt" [] e_metID +(*root-equation, version for tests before 8.01.01*) + (["Test","sqrt-equ-test"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Where" ,["contains_root (e_::bool)"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls =append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root "")], + prls =append_rls "prls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root "")], + calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ ((Rewrite square_equation_left True) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_\ + \ in [e_::bool])" + )); + +store_met + (prep_met Test.thy "met_test_sqrt2" [] e_metID +(*root-equation ... for test-*.sml until 8.01*) + (["Test","squ-equ-test2"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls = append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root"")], + prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ ((Rewrite square_equation_left True) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_;\ + \ (L_::bool list) = Tac subproblem_equation_dummy; \ + \ L_ = Tac solve_equation_dummy \ + \ in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_squ_sub" [] e_metID +(*tests subproblem fixed linear*) + (["Test","squ-equ-test-subpbl1"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], + crls=tval_rls, nrls=Test_simplify}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set norm_equation False)) @@ \ + \ (Try (Rewrite_Set Test_simplify False))) e_; \ + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ + \ [Test,solve_linear]) [bool_ e_, real_ v_])\ + \in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_squ_sub2" [] e_metID + (*tests subproblem fixed degree 2*) + (["Test","squ-equ-test-subpbl2"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*, + asm_rls=[],asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \ (let e_ = Try (Rewrite_Set norm_equation False) e_; \ + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ + \ [Test,solve_by_pq_formula]) [bool_ e_, real_ v_])\ + \in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_squ_nonterm" [] e_metID + (*root-equation: see foils..., but notTerminating*) + (["Test","square_equation...notTerminating"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls = append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root"")], + prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ ((Rewrite square_equation_left True) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_;\ + \ (L_::bool list) = \ + \ (SubProblem (Test_,[linear,univariate,equation,test],\ + \ [Test,solve_linear]) [bool_ e_, real_ v_])\ + \in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_eq1" [] e_metID +(*root-equation1:*) + (["Test","square_equation1"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls = append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root"")], + prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ ((Rewrite square_equation_left True) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_;\ + \ (L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\ + \ [Test,solve_linear]) [bool_ e_, real_ v_])\ + \ in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_squ2" [] e_metID + (*root-equation2*) + (["Test","square_equation2"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls = append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root"")], + prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ (((Rewrite square_equation_left True) Or \ + \ (Rewrite square_equation_right True)) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_;\ + \ (L_::bool list) = (SubProblem (Test_,[plain_square,univariate,equation,test],\ + \ [Test,solve_plain_square]) [bool_ e_, real_ v_])\ + \ in Check_elementwise L_ {(v_::real). Assumptions})" + )); + +store_met + (prep_met Test.thy "met_test_squeq" [] e_metID + (*root-equation*) + (["Test","square_equation"]:metID, + [("#Given" ,["equality e_","solveFor v_"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls, + srls = append_rls "srls_contains_root" e_rls + [Calc ("Test.contains'_root",eval_contains_root"")], + prls=e_rls,calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[], + asm_thm=[("square_equation_left",""), + ("square_equation_right","")]*)}, + "Script Solve_root_equation (e_::bool) (v_::real) = \ + \(let e_ = \ + \ ((While (contains_root e_) Do\ + \ (((Rewrite square_equation_left True) Or\ + \ (Rewrite square_equation_right True)) @@\ + \ (Try (Rewrite_Set Test_simplify False)) @@\ + \ (Try (Rewrite_Set rearrange_assoc False)) @@\ + \ (Try (Rewrite_Set isolate_root False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))) @@\ + \ (Try (Rewrite_Set norm_equation False)) @@\ + \ (Try (Rewrite_Set Test_simplify False)))\ + \ e_;\ + \ (L_::bool list) = (SubProblem (Test_,[univariate,equation,test],\ + \ [no_met]) [bool_ e_, real_ v_])\ + \ in Check_elementwise L_ {(v_::real). Assumptions})" + ) ); (*#######*) + +store_met + (prep_met Test.thy "met_test_eq_plain" [] e_metID + (*solve_plain_square*) + (["Test","solve_plain_square"]:metID, + [("#Given",["equality e_","solveFor v_"]), + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\ + \(matches ( ?b*v_ ^^^2 = 0) e_) |\ + \(matches (?a + v_ ^^^2 = 0) e_) |\ + \(matches ( v_ ^^^2 = 0) e_)"]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls, + prls = assoc_rls "matches", + crls=tval_rls, nrls=e_rls(*, + asm_rls=[],asm_thm=[]*)}, + "Script Solve_plain_square (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite_Set isolate_bdv False)) @@ \ + \ (Try (Rewrite_Set Test_simplify False)) @@ \ + \ ((Rewrite square_equality_0 False) Or \ + \ (Rewrite square_equality True)) @@ \ + \ (Try (Rewrite_Set tval_rls False))) e_ \ + \ in ((Or_to_List e_)::bool list))" + )); + +store_met + (prep_met Test.thy "met_test_norm_univ" [] e_metID + (["Test","norm_univar_equation"]:metID, + [("#Given",["equality e_","solveFor v_"]), + ("#Where" ,[]), + ("#Find" ,["solutions v_i_"]) + ], + {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls, + calc=[], + crls=tval_rls, nrls=e_rls(*,asm_rls=[],asm_thm=[]*)}, + "Script Norm_univar_equation (e_::bool) (v_::real) = \ + \ (let e_ = ((Try (Rewrite rnorm_equation_add False)) @@ \ + \ (Try (Rewrite_Set Test_simplify False))) e_ \ + \ in (SubProblem (Test_,[univariate,equation,test], \ + \ [no_met]) [bool_ e_, real_ v_]))" + )); + + + +(*17.9.02 aus SqRoot.ML------------------------------^^^---*) + +(*8.4.03 aus Poly.ML--------------------------------vvv--- + make_polynomial ---> make_poly + ^-- for user ^-- for systest _ONLY_*) + +local (*. for make_polytest .*) + +open Term; (* for type order = EQUAL | LESS | GREATER *) + +fun pr_ord EQUAL = "EQUAL" + | pr_ord LESS = "LESS" + | pr_ord GREATER = "GREATER"; + +fun dest_hd' (Const (a, T)) = (* ~ term.ML *) + (case a of + "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest *) + | _ => (((a, 0), T), 0)) + | dest_hd' (Free (a, T)) = (((a, 0), T), 1) + | dest_hd' (Var v) = (v, 2) + | dest_hd' (Bound i) = ((("", i), dummyT), 3) + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4); +(* RL *) +fun get_order_pow (t $ (Free(order,_))) = + (case int_of_str (order) of + SOME d => d + | NONE => 0) + | get_order_pow _ = 0; + +fun size_of_term' (Const(str,_) $ t) = + if "Atools.pow"= str then 1000 + size_of_term' t else 1 + size_of_term' t (*WN*) + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body + | size_of_term' (f$t) = size_of_term' f + size_of_term' t + | size_of_term' _ = 1; + +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *) + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord) + | term_ord' pr thy (t, u) = + (if pr then + let + val (f, ts) = strip_comb t and (g, us) = strip_comb u; + val _=writeln("t= f@ts= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\""); + val _=writeln("u= g@us= \""^ + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^ + (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\""); + val _=writeln("size_of_term(t,u)= ("^ + (string_of_int(size_of_term' t))^", "^ + (string_of_int(size_of_term' u))^")"); + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g))); + val _=writeln("terms_ord(ts,us) = "^ + ((pr_ord o terms_ord str false)(ts,us))); + val _=writeln("-------"); + in () end + else (); + case int_ord (size_of_term' t, size_of_term' u) of + EQUAL => + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us) + | ord => ord) + end + | ord => ord) +and hd_ord (f, g) = (* ~ term.ML *) + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g) +and terms_ord str pr (ts, us) = + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us); +in + +fun ord_make_polytest (pr:bool) thy (_:subst) tu = + (term_ord' pr thy(***) tu = LESS ); + +end;(*local*) + +rew_ord' := overwritel (!rew_ord', +[("termlessI", termlessI), + ("ord_make_polytest", ord_make_polytest false thy) + ]); + +(*WN060510 this was a preparation for prep_rls ... +val scr_make_polytest = +"Script Expand_binomtest t_ =\ +\(Repeat \ +\((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + +\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \ +\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \ +\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \ +\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \ +\ (Try (Repeat (Rewrite real_add_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \ +\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_)))) \ +\ t_)"; +-----------------------------------------------------*) + +val make_polytest = + Rls{id = "make_polytest", preconds = []:term list, rew_ord = ("ord_make_polytest", + ord_make_polytest false Poly.thy), + erls = testerls, srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Thm ("real_diff_minus",num_str real_diff_minus), + (*"a - b = a + (-1) * b"*) + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) + Thm ("real_mult_1",num_str real_mult_1), + (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), + (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left), + (*"0 + z = z"*) + + (*AC-rewriting*) + Thm ("real_mult_commute",num_str real_mult_commute), + (* z * w = w * z *) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*) + Thm ("real_mult_assoc",num_str real_mult_assoc), + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*) + Thm ("real_add_commute",num_str real_add_commute), + (*z + w = w + z*) + Thm ("real_add_left_commute",num_str real_add_left_commute), + (*x + (y + z) = y + (x + z)*) + Thm ("real_add_assoc",num_str real_add_assoc), + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*) + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> + l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], + scr = EmptyScr(*Script ((term_of o the o (parse thy)) + scr_make_polytest)*) + }:rls; +(*WN060510 this was done before 'fun prep_rls' ... +val scr_expand_binomtest = +"Script Expand_binomtest t_ =\ +\(Repeat \ +\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \ +\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \ +\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \ +\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \ + +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \ +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_))) @@ \ + +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \ +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \ +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \ +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \ + +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \ +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \ + +\ (Try (Repeat (Calculate plus ))) @@ \ +\ (Try (Repeat (Calculate times ))) @@ \ +\ (Try (Repeat (Calculate power_)))) \ +\ t_)"; +------------------------------------------------------*) + +val expand_binomtest = + Rls{id = "expand_binomtest", preconds = [], + rew_ord = ("termlessI",termlessI), + erls = testerls, srls = Erls, + calc = [("PLUS" , ("op +", eval_binop "#add_")), + ("TIMES" , ("op *", eval_binop "#mult_")), + ("POWER", ("Atools.pow", eval_binop "#power_")) + ], + (*asm_thm = [],*) + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2), + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*) + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times), + (*"(a + b)*(a + b) = ...*) + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2), + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*) + Thm ("real_minus_binom_times",num_str real_minus_binom_times), + (*"(a - b)*(a - b) = ...*) + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1), + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*) + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2), + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*) + (*RL 020915*) + Thm ("real_pp_binom_times",num_str real_pp_binom_times), + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*) + Thm ("real_pm_binom_times",num_str real_pm_binom_times), + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*) + Thm ("real_mp_binom_times",num_str real_mp_binom_times), + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*) + Thm ("real_mm_binom_times",num_str real_mm_binom_times), + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*) + Thm ("realpow_multI",num_str realpow_multI), + (*(a*b)^^^n = a^^^n * b^^^n*) + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3), + (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *) + Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3), + (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *) + + + (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib), + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*) + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2), + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*) + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib), + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*) + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2), + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*) + *) + + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*) + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*) + Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_"), + (* + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*) + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**) + Thm ("real_mult_assoc",num_str real_mult_assoc), (**) + Thm ("real_add_commute",num_str real_add_commute), (**) + Thm ("real_add_left_commute",num_str real_add_left_commute), (**) + Thm ("real_add_assoc",num_str real_add_assoc), (**) + *) + + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)), + (*"r1 * r1 = r1 ^^^ 2"*) + Thm ("realpow_plus_1",num_str realpow_plus_1), + (*"r * r ^^^ n = r ^^^ (n + 1)"*) + (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)), + (*"z1 + z1 = 2 * z1"*)*) + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc), + (*"z1 + (z1 + k) = 2 * z1 + k"*) + + Thm ("real_num_collect",num_str real_num_collect), + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*) + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc), + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*) + Thm ("real_one_collect",num_str real_one_collect), + (*"m is_const ==> n + m * n = (1 + m) * n"*) + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc), + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*) + + Calc ("op +", eval_binop "#add_"), + Calc ("op *", eval_binop "#mult_"), + Calc ("Atools.pow", eval_binop "#power_") + ], + scr = EmptyScr +(*Script ((term_of o the o (parse thy)) scr_expand_binomtest)*) + }:rls; + + +ruleset' := overwritelthy thy (!ruleset', + [("make_polytest", prep_rls make_polytest), + ("expand_binomtest", prep_rls expand_binomtest) + ]); + + + + + + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Test.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Test.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,158 @@ +val ttt = (term_of o the o (parse thy)) +"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_"; +val ttt = (term_of o the o (parse thy)) +"(Try (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_)"; + +val ttt = (term_of o the o (parse thy)) + "(Rewrite_Set SqRoot_simplify False) e_ "; +val ttt = (term_of o the o (parseold thy)) + "%e_. (Rewrite_Set SqRoot_simplify False) e_"; +val ttt = (term_of o the o (parseold thy)) + "Repeat (%e_. (Rewrite_Set SqRoot_simplify False)) e_"; + +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \[e_]"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \((%e_. [e_]) e_)"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \((%e_. (let e_ = e_ in [e_])) e_)"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \((%e_. \ + \ (let e_ = ((Rewrite_Set SqRoot_simplify False) e_)\ + \ in [e_]))\ + \ e_)"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \((%ee_. (let e_ = ((Rewrite_Set SqRoot_simplify False) ee_) in [e_])) e_)"; + +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = \ + \ (Repeat ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False)) e_)\ + \ in [e_])"; +(*----*) +val ttt = (term_of o the o (parse thy)) + +(*----*) +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = \ + \ (Repeat\ + \ ((%ee_. (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\ + \ e_)\ + \ e_)\ + \ in [e_])"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = \ + \ (Repeat\ + \ ((%ee_.\ + \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_))\ + \ e_)\ + \ e_)\ + \ in [e_])"; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = \ + \ (Repeat\ + \ ((%ee_.\ + \ (let e_ = ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\ + \ in ((Rewrite_Set SqRoot_simplify False) e_)) )\ + \ e_)\ + \ e_)\ + \ in [e_])"; +atomty ttt; +atomt ttt; + +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ (Rewrite rmult_1 False) g_"; +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ (((Rewrite rmult_1 False)) Or ((Rewrite rmult_0 False))) g_"; +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ ((Repeat (Rewrite rmult_1 False)) Or (Repeat (Rewrite rmult_0 False))) g_"; +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ ((Repeat (Rewrite rmult_1 False)) Or\ + \ (Repeat (Rewrite rmult_0 False))) g_"; +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ ((Repeat (Rewrite rmult_1 False)) Or\ + \ (Repeat (Rewrite rmult_0 False)) Or\ + \ (Repeat (Rewrite rmult_0 False))) g_"; +val ttt = (term_of o the o (parse thy)) + "Script Testterm (g_::real) = \ + \Repeat\ + \ ((Try Repeat (Rewrite rmult_1 False)) Or\ + \ (Try Repeat (Rewrite rmult_0 False)) Or\ + \ (Try Repeat (Rewrite rmult_0 False))) g_"; + + + + + + + + + + + + + +(*################### 29.4.02: Rewrite o Rewrite o ...###############*) +(*################### 29.4.02: Rewrite o Rewrite o ...###############*) +(*################### 29.4.02: Rewrite o Rewrite o ...###############*) + + + +atomt ttt; +val ttt = (term_of o the o (parse thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = \ + \ ((Repeat\ + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Rewrite_Set SqRoot_simplify False)))) e_)\ + \ in [e_])"; +atomty ttt; + + +val ttt = (term_of o the o (parse thy)) +"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@ yyy"; +atomty ttt; +val ttt = (term_of o the o (parse thy)) + "(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Rewrite_Set SqRoot_simplify False)"; +atomty ttt; +val ttt = (term_of o the o (parse thy)) + "(Repeat\ + \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Rewrite_Set SqRoot_simplify False))) e_"; +atomty ttt; +val ttt = (term_of o the o (parseold thy)) +"(let e_ = Repeat xxx e_ in [e_::bool])"; +atomty ttt; +val ttt = (term_of o the o (parseold thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ = Repeat (xxx) e_ in [e_::bool])"; +atomty ttt; +val ttt = (term_of o the o (parseold thy)) + "Script Solve_linear (e_::bool) (v_::real)= \ + \(let e_ =\ + \ Repeat\ + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\ + \ (Rewrite_Set SqRoot_simplify False))) e_\ + \ in [e_::bool])" +; +atomty ttt; + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Test.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Test.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,169 @@ +(* use_thy"Knowledge/Test"; + *) + +Test = Atools + Rational + Root + Poly + + +consts + +(*"cancel":: [real, real] => real (infixl "'/'/'/" 70) ...divide 2002*) + + Expand'_binomtest + :: "['y, \ + \ 'y] => 'y" + ("((Script Expand'_binomtest (_ =))// \ + \ (_))" 9) + + Solve'_univar'_err + :: "[bool,real,bool, \ + \ bool list] => bool list" + ("((Script Solve'_univar'_err (_ _ _ =))// \ + \ (_))" 9) + + Solve'_linear + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_linear (_ _ =))// \ + \ (_))" 9) + +(*17.9.02 aus SqRoot.thy------------------------------vvv---*) + + "is'_root'_free" :: 'a => bool ("is'_root'_free _" 10) + "contains'_root" :: 'a => bool ("contains'_root _" 10) + + Solve'_root'_equation + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_root'_equation (_ _ =))// \ + \ (_))" 9) + + Solve'_plain'_square + :: "[bool,real, \ + \ bool list] => bool list" + ("((Script Solve'_plain'_square (_ _ =))// \ + \ (_))" 9) + + Norm'_univar'_equation + :: "[bool,real, \ + \ bool] => bool" + ("((Script Norm'_univar'_equation (_ _ =))// \ + \ (_))" 9) + + STest'_simplify + :: "['z, \ + \ 'z] => 'z" + ("((Script STest'_simplify (_ =))// \ + \ (_))" 9) + +(*17.9.02 aus SqRoot.thy------------------------------^^^---*) + +rules (*stated as axioms, todo: prove as theorems*) + + radd_mult_distrib2 "(k::real) * (m + n) = k * m + k * n" + rdistr_right_assoc "(k::real) + l * n + m * n = k + (l + m) * n" + rdistr_right_assoc_p "l * n + (m * n + (k::real)) = (l + m) * n + k" + rdistr_div_right "((k::real) + l) / n = k / n + l / n" + rcollect_right + "[| l is_const; m is_const |] ==> (l::real)*n + m*n = (l + m) * n" + rcollect_one_left + "m is_const ==> (n::real) + m * n = (1 + m) * n" + rcollect_one_left_assoc + "m is_const ==> (k::real) + n + m * n = k + (1 + m) * n" + rcollect_one_left_assoc_p + "m is_const ==> n + (m * n + (k::real)) = (1 + m) * n + k" + + rtwo_of_the_same "a + a = 2 * a" + rtwo_of_the_same_assoc "(x + a) + a = x + 2 * a" + rtwo_of_the_same_assoc_p"a + (a + x) = 2 * a + x" + + rcancel_den "not(a=0) ==> a * (b / a) = b" + rcancel_const "[| a is_const; b is_const |] ==> a*(x/b) = a/b*x" + rshift_nominator "(a::real) * b / c = a / c * b" + + exp_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)" + rsqare "(a::real) * a = a ^^^ 2" + power_1 "(a::real) ^^^ 1 = a" + rbinom_power_2 "((a::real) + b)^^^ 2 = a^^^ 2 + 2*a*b + b^^^ 2" + + rmult_1 "1 * k = (k::real)" + rmult_1_right "k * 1 = (k::real)" + rmult_0 "0 * k = (0::real)" + rmult_0_right "k * 0 = (0::real)" + radd_0 "0 + k = (k::real)" + radd_0_right "k + 0 = (k::real)" + + radd_real_const_eq + "[| a is_const; c is_const; d is_const |] ==> a/d + c/d = (a+c)/(d::real)" + radd_real_const + "[| a is_const; b is_const; c is_const; d is_const |] ==> a/b + c/d = (a*d + b*c)/(b*(d::real))" + +(*for AC-operators*) + radd_commute "(m::real) + (n::real) = n + m" + radd_left_commute "(x::real) + (y + z) = y + (x + z)" + radd_assoc "(m::real) + n + k = m + (n + k)" + rmult_commute "(m::real) * n = n * m" + rmult_left_commute "(x::real) * (y * z) = y * (x * z)" + rmult_assoc "(m::real) * n * k = m * (n * k)" + +(*for equations: 'bdv' is a meta-constant*) + risolate_bdv_add "((k::real) + bdv = m) = (bdv = m + (-1)*k)" + risolate_bdv_mult_add "((k::real) + n*bdv = m) = (n*bdv = m + (-1)*k)" + risolate_bdv_mult "((n::real) * bdv = m) = (bdv = m / n)" + + rnorm_equation_add + "~(b =!= 0) ==> (a = b) = (a + (-1)*b = 0)" + +(*17.9.02 aus SqRoot.thy------------------------------vvv---*) + root_ge0 "0 <= a ==> 0 <= sqrt a" + (*should be dropped with better simplification in eval_rls ...*) + root_add_ge0 + "[| 0 <= a; 0 <= b |] ==> (0 <= sqrt a + sqrt b) = True" + root_ge0_1 + "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= a * sqrt b + sqrt c) = True" + root_ge0_2 + "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= sqrt a + b * sqrt c) = True" + + + rroot_square_inv "(sqrt a)^^^ 2 = a" + rroot_times_root "sqrt a * sqrt b = sqrt(a*b)" + rroot_times_root_assoc "(a * sqrt b) * sqrt c = a * sqrt(b*c)" + rroot_times_root_assoc_p "sqrt b * (sqrt c * a)= sqrt(b*c) * a" + + +(*for root-equations*) + square_equation_left + "[| 0 <= a; 0 <= b |] ==> (((sqrt a)=b)=(a=(b^^^ 2)))" + square_equation_right + "[| 0 <= a; 0 <= b |] ==> ((a=(sqrt b))=((a^^^ 2)=b))" + (*causes frequently non-termination:*) + square_equation + "[| 0 <= a; 0 <= b |] ==> ((a=b)=((a^^^ 2)=b^^^ 2))" + + risolate_root_add "(a+ sqrt c = d) = ( sqrt c = d + (-1)*a)" + risolate_root_mult "(a+b*sqrt c = d) = (b*sqrt c = d + (-1)*a)" + risolate_root_div "(a * sqrt c = d) = ( sqrt c = d / a)" + +(*for polynomial equations of degree 2; linear case in RatArith*) + mult_square "(a*bdv^^^2 = b) = (bdv^^^2 = b / a)" + constant_square "(a + bdv^^^2 = b) = (bdv^^^2 = b + -1*a)" + constant_mult_square "(a + b*bdv^^^2 = c) = (b*bdv^^^2 = c + -1*a)" + + square_equality + "0 <= a ==> (x^^^2 = a) = ((x=sqrt a) | (x=-1*sqrt a))" + square_equality_0 + "(x^^^2 = 0) = (x = 0)" + +(*isolate root on the LEFT hand side of the equation + otherwise shuffling from left to right would not terminate*) + + rroot_to_lhs + "is_root_free a ==> (a = sqrt b) = (a + (-1)*sqrt b = 0)" + rroot_to_lhs_mult + "is_root_free a ==> (a = c*sqrt b) = (a + (-1)*c*sqrt b = 0)" + rroot_to_lhs_add_mult + "is_root_free a ==> (a = d+c*sqrt b) = (a + (-1)*c*sqrt b = d)" + + +(*17.9.02 aus SqRoot.thy------------------------------^^^---*) + + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Trig.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Trig.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,4 @@ + +Trig = Real + + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Typefix.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Typefix.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,32 @@ +(* Title: fixed type for _RE_parsing of strings from frontend + Author: Walther Neuper + 9911xx + (c) due to copyright terms + with hints from Markus Wenzel + *) + +theory Typefix imports "../ProgLang/Script" begin + +syntax + + "_plus" :: 'a + "_minus" :: 'a + "_umin" :: 'a + "_times" :: 'a + +translations + + "op +" => "_plus :: [real, real] => real" (*infixl 65 *) + "op -" => "_minus :: [real, real] => real" (*infixl 65 *) + "uminus"=> "_umin :: [real] => real" (*"- _" [80] 80*) + "op *" => "_times :: [real, real] => real" (*infixl 70 *) + +ML {* +val parse_translation = + [("_plus", curry Term.list_comb (Syntax.const "op +")), + ("_minus", curry Term.list_comb (Syntax.const "op -")), + ("_umin", curry Term.list_comb (Syntax.const "uminus")), + ("_times", curry Term.list_comb (Syntax.const "op *"))]; +*} + +end \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Knowledge/Vect.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/Knowledge/Vect.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,5 @@ +Vect = Real + +(*-------------------- consts ------------------------------------------------*) + +(*-------------------- rules -------------------------------------------------*) +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/appl.sml --- a/src/Tools/isac/ME/appl.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,782 +0,0 @@ -(* use"ME/appl.sml"; - use"appl.sml"; - -12345678901234567890123456789012345678901234567890123456789012345678901234567890 - 10 20 30 40 50 60 70 80 -*) -val e_cterm' = empty_cterm'; - - -fun rew_info (Rls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = - (rew_ord':rew_ord',erls,ca) - | rew_info (Seq {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = - (rew_ord',erls,ca) - | rew_info (Rrls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) = - (rew_ord',erls, ca) - | rew_info rls = raise error ("rew_info called with '"^rls2str rls^"'"); - -(*FIXME.3.4.03:re-organize from_pblobj_or_detail_thm after rls' --> rls*) -fun from_pblobj_or_detail_thm thm' p pt = - let val (pbl,p',rls') = par_pbl_det pt p - in if pbl - then let (*val _= writeln("### from_pblobj_or_detail_thm: pbl=true")*) - val thy' = get_obj g_domID pt p' - val {rew_ord',erls,(*asm_thm,*)...} = - get_met (get_obj g_metID pt p') - (*val _= writeln("### from_pblobj_or_detail_thm: metID= "^ - (metID2str(get_obj g_metID pt p'))) - val _= writeln("### from_pblobj_or_detail_thm: erls= "^erls)*) - in ("OK",thy',rew_ord',erls,(*put_asm*)false) - end - else ((*writeln("### from_pblobj_or_detail_thm: pbl=false");*) - (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize !!! - NONE => ("unknown ruleset '"^rls'^"'","","",Erls,false) - | SOME rls =>*) - let val thy' = get_obj g_domID pt (par_pblobj pt p) - val (rew_ord',erls,(*asm_thm,*)_) = rew_info rls' - in ("OK",thy',rew_ord',erls,false) end) - end; -(*FIXME.3.4.03:re-organize from_pblobj_or_detail_calc after rls' --> rls*) -fun from_pblobj_or_detail_calc scrop p pt = -(* val (scrop, p, pt) = (op_, p, pt); - *) - let val (pbl,p',rls') = par_pbl_det pt p - in if pbl - then let val thy' = get_obj g_domID pt p' - val {calc = scr_isa_fns,...} = - get_met (get_obj g_metID pt p') - val opt = assoc (scr_isa_fns, scrop) - in case opt of - SOME isa_fn => ("OK",thy',isa_fn) - | NONE => ("applicable_in Calculate: unknown '"^scrop^"'", - "",("",e_evalfn)) end - else (*case assoc(!ruleset', rls') of - NONE => ("unknown ruleset '"^rls'^"'","",("",e_evalfn)) - | SOME rls => !!!FIXME.3.4.03:re-organize from_pblobj_or_detai*) - (* val SOME rls = assoc(!ruleset', rls'); - *) - let val thy' = get_obj g_domID pt (par_pblobj pt p); - val (_,_,(*_,*)scr_isa_fns) = rew_info rls'(*rls*) - in case assoc (scr_isa_fns, scrop) of - SOME isa_fn => ("OK",thy',isa_fn) - | NONE => ("applicable_in Calculate: unknown '"^scrop^"'", - "",("",e_evalfn)) end - end; -(*------------------------------------------------------------------*) - -val op_and = Const ("op &", [bool, bool] ---> bool); -(*> (cterm_of thy) (op_and $ Free("a",bool) $ Free("b",bool)); -val it = "a & b" : cterm -*) -fun mk_and a b = op_and $ a $ b; -(*> (cterm_of thy) - (mk_and (Free("a",bool)) (Free("b",bool))); -val it = "a & b" : cterm*) - -fun mk_and [] = HOLogic.true_const - | mk_and (t::[]) = t - | mk_and (t::ts) = - let fun mk t' (t::[]) = op_and $ t' $ t - | mk t' (t::ts) = mk (op_and $ t' $ t) ts - in mk t ts end; -(*> val pred = map (term_of o the o (parse thy)) - ["#0 <= #9 + #4 * x","#0 <= sqrt x + sqrt (#-3 + x)"]; -> (cterm_of thy) (mk_and pred); -val it = "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)" : cterm*) - - - - -(*for Check_elementwise in applicable_in: [x=1,..] Assumptions -> (x,0<=x&..)*) -fun mk_set thy pt p (Const ("List.list.Nil",_)) pred = (e_term, []) - - | mk_set thy pt p (Const ("Tools.UniversalList",_)) pred = - (e_term, if pred <> Const ("Script.Assumptions",bool) - then [pred] - else (map fst) (get_assumptions_ pt (p,Res))) - -(* val pred = (term_of o the o (parse thy)) pred; - val consts as Const ("List.list.Cons",_) $ eq $ _ = ft; - mk_set thy pt p consts pred; - *) - | mk_set thy pt p (consts as Const ("List.list.Cons",_) $ eq $ _) pred = - let val (bdv,_) = HOLogic.dest_eq eq; - val pred = if pred <> Const ("Script.Assumptions",bool) - then [pred] - else (map fst) (get_assumptions_ pt (p,Res)) - in (bdv, pred) end - - | mk_set thy _ _ l _ = - raise error ("check_elementwise: no set "^ - (Syntax.string_of_term (thy2ctxt thy) l)); -(*> val consts = str2term "[x=#4]"; -> val pred = str2term "Assumptions"; -> val pt = union_asm pt p - [("#0 <= sqrt x + sqrt (#5 + x)",[11]),("#0 <= #9 + #4 * x",[22]), - ("#0 <= x ^^^ #2 + #5 * x",[33]),("#0 <= #2 + x",[44])]; -> val p = []; -> val (sss,ttt) = mk_set thy pt p consts pred; -> (Syntax.string_of_term (thy2ctxt thy) sss,Syntax.string_of_term(thy2ctxt thy) ttt); -val it = ("x","((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & ... - - val consts = str2term "UniversalList"; - val pred = str2term "Assumptions"; - -*) - - - -(*check a list (/set) of constants [c_1,..,c_n] for c_i:set (: in)*) -(* val (erls,consts,(bdv,pred)) = (erl,ft,vp); - val (consts,(bdv,pred)) = (ft,vp); - *) -fun check_elementwise thy erls all_results (bdv, asm) = - let (*bdv extracted from ~~~~~~~~~~~ in mk_set already*) - fun check sub = - let val inst_ = map (subst_atomic [sub]) asm - in case eval__true thy 1 inst_ [] erls of - (asm', true) => ([HOLogic.mk_eq sub], asm') - | (_, false) => ([],[]) - end; - (*val _= writeln("### check_elementwise: res= "^(term2str all_results)^ - ", bdv= "^(term2str bdv)^", asm= "^(terms2str asm));*) - val c' = isalist2list all_results - val c'' = map (snd o HOLogic.dest_eq) c' (*assumes [x=1,x=2,..]*) - val subs = map (pair bdv) c'' - in if asm = [] then (all_results, []) - else ((apfst ((list2isalist bool) o flat)) o - (apsnd flat) o split_list o (map check)) subs end; -(* 20.5.03 -> val all_results = str2term "[x=a+b,x=b,x=3]"; -> val bdv = str2term "x"; -> val asm = str2term "(x ~= a) & (x ~= b)"; -> val erls = e_rls; -> val (t, ts) = check_elementwise thy erls all_results (bdv, asm); -> term2str t; writeln(terms2str ts); -val it = "[x = a + b, x = b, x = c]" : string -["a + b ~= a & a + b ~= b","b ~= a & b ~= b","c ~= a & c ~= b"] -... with appropriate erls this should be: -val it = "[x = a + b, x = c]" : string -["b ~= 0 & a ~= 0", "3 ~= a & 3 ~= b"] - ////// because b ~= b False*) - - - -(*before 5.03----- -> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #3) + sqrt (#5 - #3)) &\ - \ #0 <= #25 + #-1 * #3 ^^^ #2) & #0 <= #4"; -> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct; -val ct' = "True" : cterm' - -> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #-3) + sqrt (#5 - #-3)) &\ - \ #0 <= #25 + #-1 * #-3 ^^^ #2) & #0 <= #4"; -> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct; -val ct' = "True" : cterm' - - -> val const = (term_of o the o (parse thy)) "(#3::real)"; -> val pred' = subst_atomic [(bdv,const)] pred; - - -> val consts = (term_of o the o (parse thy)) "[x = #-3, x = #3]"; -> val bdv = (term_of o the o (parse thy)) "(x::real)"; -> val pred = (term_of o the o (parse thy)) - "((#0 <= #18 & #0 <= sqrt (#5 + x) + sqrt (#5 - x)) & #0 <= #25 + #-1 * x ^^^ #2) & #0 <= #4"; -> val ttt = check_elementwise thy consts (bdv, pred); -> (cterm_of thy) ttt; -val it = "[x = #-3, x = #3]" : cterm - -> val consts = (term_of o the o (parse thy)) "[x = #4]"; -> val bdv = (term_of o the o (parse thy)) "(x::real)"; -> val pred = (term_of o the o (parse thy)) - "#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #5 * x & #0 <= #2 + x"; -> val ttt = check_elementwise thy consts (bdv,pred); -> (cterm_of thy) ttt; -val it = "[x = #4]" : cterm - -> val consts = (term_of o the o (parse thy)) "[x = #-12 // #5]"; -> val bdv = (term_of o the o (parse thy)) "(x::real)"; -> val pred = (term_of o the o (parse thy)) - " #0 <= sqrt x + sqrt (#-3 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #-3 * x & #0 <= #6 + x"; -> val ttt = check_elementwise thy consts (bdv,pred); -> (cterm_of thy) ttt; -val it = "[]" : cterm*) - - -(* 14.1.01: for Tac-dummies in root-equ only: skip str until "("*) -fun split_dummy str = -let fun scan s' [] = (implode s', "") - | scan s' (s::ss) = if s=" " then (implode s', implode ss) - else scan (s'@[s]) ss; -in ((scan []) o explode) str end; -(* split_dummy "subproblem_equation_dummy (x=-#5//#12)"; -val it = ("subproblem_equation_dummy","(x=-#5//#12)") : string * string -> split_dummy "x=-#5//#12"; -val it = ("x=-#5//#12","") : string * string*) - - - - -(*.applicability of a tacic wrt. a calc-state (ptree,pos'). - additionally used by next_tac in the script-interpreter for sequence-tacs. - tests for applicability are so expensive, that results (rewrites!) - are kept in the return-value of 'type tac_'. -.*) -fun applicable_in (_:pos') _ (Init_Proof (ct', spec)) = - Appl (Init_Proof' (ct', spec)) - - | applicable_in (p,p_) pt Model_Problem = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str Model_Problem)^ - " not for pos "^(pos'2str (p,p_))) - else let val (PblObj{origin=(_,(_,pI',_),_),...}) = get_obj I pt p - val {ppc,...} = get_pbt pI' - val pbl = init_pbl ppc - in Appl (Model_Problem' (pI', pbl, [])) end -(* val Refine_Tacitly pI = m; - *) - | applicable_in (p,p_) pt (Refine_Tacitly pI) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Refine_Tacitly pI))^ - " not for pos "^(pos'2str (p,p_))) - else (* val Refine_Tacitly pI = m; - *) - let val (PblObj {origin = (oris, (dI',_,_),_), ...}) = get_obj I pt p; - val opt = refine_ori oris pI; - in case opt of - SOME pblID => - Appl (Refine_Tacitly' (pI, pblID, - e_domID, e_metID, [](*filled in specify*))) - | NONE => Notappl ((tac2str (Refine_Tacitly pI))^ - " not applicable") end -(* val (p,p_) = ip; - val Refine_Problem pI = m; - *) - | applicable_in (p,p_) pt (Refine_Problem pI) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Refine_Problem pI))^ - " not for pos "^(pos'2str (p,p_))) - else - let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_), - probl=itms, ...}) = get_obj I pt p; - val thy = if dI' = e_domID then dI else dI'; - val rfopt = refine_pbl (assoc_thy thy) pI itms; - in case rfopt of - NONE => Notappl ((tac2str (Refine_Problem pI))^" not applicable") - | SOME (rf as (pI',_)) => -(* val SOME (rf as (pI',_)) = rfopt; - *) - if pI' = pI - then Notappl ((tac2str (Refine_Problem pI))^" not applicable") - else Appl (Refine_Problem' rf) - end - - (*the specify-tacs have cterm' instead term: - parse+error here!!!: see appl_add*) - | applicable_in (p,p_) pt (Add_Given ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Add_Given ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Add_Given' (ct', [(*filled in specify_additem*)])) - (*Add_.. should reject (dsc //) (see fmz=[] in sqrt*) - - | applicable_in (p,p_) pt (Del_Given ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Del_Given ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Del_Given' ct') - - | applicable_in (p,p_) pt (Add_Find ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Add_Find ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Add_Find' (ct', [(*filled in specify_additem*)])) - - | applicable_in (p,p_) pt (Del_Find ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Del_Find ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Del_Find' ct') - - | applicable_in (p,p_) pt (Add_Relation ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Add_Relation ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Add_Relation' (ct', [(*filled in specify_additem*)])) - - | applicable_in (p,p_) pt (Del_Relation ct') = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Del_Relation ct'))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Del_Relation' ct') - - | applicable_in (p,p_) pt (Specify_Theory dI) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Specify_Theory dI))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Specify_Theory' dI) -(* val (p,p_) = p; val Specify_Problem pID = m; - val Specify_Problem pID = m; - *) - | applicable_in (p,p_) pt (Specify_Problem pID) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Specify_Problem pID))^ - " not for pos "^(pos'2str (p,p_))) - else - let val (PblObj {origin=(oris,(dI,pI,_),_),spec=(dI',pI',_), - probl=itms, ...}) = get_obj I pt p; - val thy = assoc_thy (if dI' = e_domID then dI else dI'); - val {ppc,where_,prls,...} = get_pbt pID; - val pbl = if pI'=e_pblID andalso pI=e_pblID - then (false, (init_pbl ppc, [])) - else match_itms_oris thy itms (ppc,where_,prls) oris; - in Appl (Specify_Problem' (pID, pbl)) end -(* val Specify_Method mID = nxt; val (p,p_) = p; - *) - | applicable_in (p,p_) pt (Specify_Method mID) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Specify_Method mID))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Specify_Method' (mID,[(*filled in specify*)], - [(*filled in specify*)])) - - | applicable_in (p,p_) pt (Apply_Method mI) = - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res - then Notappl ((tac2str (Apply_Method mI))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Apply_Method' (mI, NONE, e_istate (*filled in solve*))) - - | applicable_in (p,p_) pt (Check_Postcond pI) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str (Check_Postcond pI))^ - " not for pos "^(pos'2str (p,p_))) - else Appl (Check_Postcond' - (pI,(e_term,[(*asm in solve*)]))) - (* in solve -"- ^^^^^^ gets returnvalue of scr*) - - (*these are always applicable*) - | applicable_in (p,p_) _ (Take str) = Appl (Take' (str2term str)) - | applicable_in (p,p_) _ (Free_Solve) = Appl (Free_Solve') - -(* val m as Rewrite_Inst (subs, thm') = m; - *) - | applicable_in (p,p_) pt (m as Rewrite_Inst (subs, thm')) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val {rew_ord'=ro',erls=erls,...} = - get_met (get_obj g_metID pt pp); - val (f,p) = case p_ of (*p 12.4.00 unnecessary*) - Frm => (get_obj g_form pt p, p) - | Res => ((fst o (get_obj g_result pt)) p, lev_on p) - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in - let val subst = subs2subst thy subs; - val subs' = subst2subs' subst; - in case rewrite_inst_ thy (assoc_rew_ord ro') erls - (*put_asm*)false subst (assoc_thm' thy thm') f of - SOME (f',asm) => Appl ( - Rewrite_Inst' (thy',ro',erls,(*put_asm*)false,subst,thm', - (*term_of o the o (parse (assoc_thy thy'))*) f, - (*(term_of o the o (parse (assoc_thy thy'))*) (f', - (*map (term_of o the o (parse (assoc_thy thy')))*) asm))) - | NONE => Notappl ((fst thm')^" not applicable") end - handle _ => Notappl ("syntax error in "^(subs2str subs)) end - -(* val ((p,p_), pt, m as Rewrite thm') = (p, pt, m); - val ((p,p_), pt, m as Rewrite thm') = (pos, pt, tac); - *) -| applicable_in (p,p_) pt (m as Rewrite thm') = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let val (msg,thy',ro,rls',(*put_asm*)_)= from_pblobj_or_detail_thm thm' p pt; - val thy = assoc_thy thy'; - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - | _ => raise error ("applicable_in Rewrite: call by "^ - (pos'2str (p,p_))); - in if msg = "OK" - then - ((*writeln("### applicable_in rls'= "^rls');*) - (* val SOME (f',asm)=rewrite thy' ro (id_rls rls') put_asm thm' f; - *) - case rewrite_ thy (assoc_rew_ord ro) - rls' false (assoc_thm' thy thm') f of - SOME (f',asm) => Appl ( - Rewrite' (thy',ro,rls',(*put_asm*)false,thm', f, (f', asm))) - | NONE => Notappl ("'"^(fst thm')^"' not applicable") ) - else Notappl msg - end - -| applicable_in (p,p_) pt (m as Rewrite_Asm thm') = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val {rew_ord'=ro',erls=erls,...} = - get_met (get_obj g_metID pt pp); - (*val put_asm = true;*) - val (f,p) = case p_ of (*p 12.4.00 unnecessary*) - Frm => (get_obj g_form pt p, p) - | Res => ((fst o (get_obj g_result pt)) p, lev_on p) - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in case rewrite_ thy (assoc_rew_ord ro') erls - (*put_asm*)false (assoc_thm' thy thm') f of - SOME (f',asm) => Appl ( - Rewrite' (thy',ro',erls,(*put_asm*)false,thm', f, (f', asm))) - | NONE => Notappl ("'"^(fst thm')^"' not applicable") end - - | applicable_in (p,p_) pt (m as Detail_Set_Inst (subs, rls)) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val {rew_ord'=ro',...} = get_met (get_obj g_metID pt pp); - val f = case p_ of Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in - let val subst = subs2subst thy subs - val subs' = subst2subs' subst - in case rewrite_set_inst_ thy false subst (assoc_rls rls) f of - SOME (f',asm) => Appl ( - Detail_Set_Inst' (thy',false,subst,assoc_rls rls, f, (f', asm))) - | NONE => Notappl (rls^" not applicable") end - handle _ => Notappl ("syntax error in "^(subs2str subs)) end - - | applicable_in (p,p_) pt (m as Rewrite_Set_Inst (subs, rls)) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val {rew_ord'=ro',(*asm_rls=asm_rls,*)...} = - get_met (get_obj g_metID pt pp); - val (f,p) = case p_ of (*p 12.4.00 unnecessary*) - Frm => (get_obj g_form pt p, p) - | Res => ((fst o (get_obj g_result pt)) p, lev_on p) - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in - let val subst = subs2subst thy subs; - val subs' = subst2subs' subst; - in case rewrite_set_inst_ thy (*put_asm*)false subst (assoc_rls rls) f of - SOME (f',asm) => Appl ( - Rewrite_Set_Inst' (thy',(*put_asm*)false,subst,assoc_rls rls, f, (f', asm))) - | NONE => Notappl (rls^" not applicable") end - handle _ => Notappl ("syntax error in "^(subs2str subs)) end - - | applicable_in (p,p_) pt (m as Rewrite_Set rls) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val (f,p) = case p_ of (*p 12.4.00 unnecessary*) - Frm => (get_obj g_form pt p, p) - | Res => ((fst o (get_obj g_result pt)) p, lev_on p) - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of - SOME (f',asm) => - ((*writeln("#.# applicable_in Rewrite_Set,2f'= "^f');*) - Appl (Rewrite_Set' (thy',(*put_asm*)false,assoc_rls rls, f, (f', asm))) - ) - | NONE => Notappl (rls^" not applicable") end - - | applicable_in (p,p_) pt (m as Detail_Set rls) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let val pp = par_pblobj pt p - val thy' = (get_obj g_domID pt pp):theory' - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of - SOME (f',asm) => - Appl (Detail_Set' (thy',false,assoc_rls rls, f, (f',asm))) - | NONE => Notappl (rls^" not applicable") end - - - | applicable_in p pt (End_Ruleset) = - raise error ("applicable_in: not impl. for "^ - (tac2str End_Ruleset)) - -(* val ((p,p_), pt, (m as Calculate op_)) = (p, pt, m); - *) -| applicable_in (p,p_) pt (m as Calculate op_) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val (msg,thy',isa_fn) = from_pblobj_or_detail_calc op_ p pt; - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - in if msg = "OK" then - case calculate_ (assoc_thy thy') isa_fn f of - SOME (f', (id, thm)) => - Appl (Calculate' (thy',op_, f, (f', (id, string_of_thmI thm)))) - | NONE => Notappl ("'calculate "^op_^"' not applicable") - else Notappl msg - end - -(*Substitute combines two different kind of "substitution": - (1) subst_atomic: for ?a..?z - (2) Pattern.match: for solving equational systems - (which raises exn for ?a..?z)*) - | applicable_in (p,p_) pt (m as Substitute sube) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else let val pp = par_pblobj pt p - val thy = assoc_thy (get_obj g_domID pt pp) - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp) - val subte = sube2subte sube - val subst = sube2subst thy sube - in if foldl and_ (true, map contains_Var subte) - (*1*) - then let val f' = subst_atomic subst f - in if f = f' then Notappl (sube2str sube^" not applicable") - else Appl (Substitute' (subte, f, f')) - end - (*2*) - else case rewrite_terms_ thy (assoc_rew_ord rew_ord') - erls subte f of - SOME (f', _) => Appl (Substitute' (subte, f, f')) - | NONE => Notappl (sube2str sube^" not applicable") - end -(*-------WN08114 interrupted with error in polyminus.sml "11 = 11" - | applicable_in (p,p_) pt (m as Substitute sube) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else let val pp = par_pblobj pt p - val thy = assoc_thy (get_obj g_domID pt pp) - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp) - val subte = sube2subte sube - in case rewrite_terms_ thy (assoc_rew_ord rew_ord') erls subte f of - SOME (f', _) => Appl (Substitute' (subte, f, f')) - | NONE => Notappl (sube2str sube^" not applicable") - end -------------------*) - - | applicable_in p pt (Apply_Assumption cts') = - (raise error ("applicable_in: not impl. for "^ - (tac2str (Apply_Assumption cts')))) - - (*'logical' applicability wrt. script in locate: Inconsistent?*) - | applicable_in (p,p_) pt (m as Take ct') = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let val thy' = get_obj g_domID pt (par_pblobj pt p); - in (case parse (assoc_thy thy') ct' of - SOME ct => Appl (Take' (term_of ct)) - | NONE => Notappl ("syntax error in "^ct')) - end - - | applicable_in p pt (Take_Inst ct') = - raise error ("applicable_in: not impl. for "^ - (tac2str (Take_Inst ct'))) - - | applicable_in p pt (Group (con, ints)) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Group (con, ints)))) - - | applicable_in (p,p_) pt (m as Subproblem (domID, pblID)) = - if member op = [Pbl,Met] p_ - then (*maybe Apply_Method has already been done*) - case get_obj g_env pt p of - SOME is => Appl (Subproblem' ((domID, pblID, e_metID), [], - e_term, [], subpbl domID pblID)) - | NONE => Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else (*somewhere later in the script*) - Appl (Subproblem' ((domID, pblID, e_metID), [], - e_term, [], subpbl domID pblID)) - - | applicable_in p pt (End_Subproblem) = - raise error ("applicable_in: not impl. for "^ - (tac2str (End_Subproblem))) - - | applicable_in p pt (CAScmd ct') = - raise error ("applicable_in: not impl. for "^ - (tac2str (CAScmd ct'))) - - | applicable_in p pt (Split_And) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Split_And))) - | applicable_in p pt (Conclude_And) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Conclude_And))) - | applicable_in p pt (Split_Or) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Split_Or))) - | applicable_in p pt (Conclude_Or) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Conclude_Or))) - - | applicable_in (p,p_) pt (Begin_Trans) = - let - val (f,p) = case p_ of (*p 12.4.00 unnecessary*) - (*_____ implizit Take in gen*) - Frm => (get_obj g_form pt p, (lev_on o lev_dn) p) - | Res => ((fst o (get_obj g_result pt)) p, (lev_on o lev_dn o lev_on) p) - | _ => raise error ("applicable_in: call by "^ - (pos'2str (p,p_))); - val thy' = get_obj g_domID pt (par_pblobj pt p); - in (Appl (Begin_Trans' f)) - handle _ => raise error ("applicable_in: Begin_Trans finds \ - \syntaxerror in '"^(term2str f)^"'") end - - (*TODO: check parent branches*) - | applicable_in (p,p_) pt (End_Trans) = - let val thy' = get_obj g_domID pt (par_pblobj pt p); - in if p_ = Res - then Appl (End_Trans' (get_obj g_result pt p)) - else Notappl "'End_Trans' is not applicable at \ - \the beginning of a transitive sequence" - (*TODO: check parent branches*) - end - - | applicable_in p pt (Begin_Sequ) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Begin_Sequ))) - | applicable_in p pt (End_Sequ) = - raise error ("applicable_in: not impl. for "^ - (tac2str (End_Sequ))) - | applicable_in p pt (Split_Intersect) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Split_Intersect))) - | applicable_in p pt (End_Intersect) = - raise error ("applicable_in: not impl. for "^ - (tac2str (End_Intersect))) -(* val Appl (Check_elementwse'(t1,"Assumptions",t2)) = it; - val (vvv,ppp) = vp; - - val Check_elementwise pred = m; - - val ((p,p_), Check_elementwise pred) = (p, m); - *) - | applicable_in (p,p_) pt (m as Check_elementwise pred) = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy' - val metID = (get_obj g_metID pt pp) - val {crls,...} = get_met metID - (*val _=writeln("### applicable_in Check_elementwise: crls= "^crls) - val _=writeln("### applicable_in Check_elementwise: pred= "^pred)*) - (*val erl = the (assoc'(!ruleset',crls))*) - val (f,asm) = case p_ of - Frm => (get_obj g_form pt p , []) - | Res => get_obj g_result pt p; - (*val _= writeln("### applicable_in Check_elementwise: f= "^f);*) - val vp = mk_set thy pt p f ((term_of o the o (parse thy)) pred); - (*val (v,p)=vp;val _=writeln("### applicable_in Check_elementwise: vp= "^ - pair2str(term2str v,term2str p))*) - in case f of - Const ("List.list.Cons",_) $ _ $ _ => - Appl (Check_elementwise' - (f, pred, - ((*writeln("### applicable_in Check_elementwise: --> "^ - (res2str (check_elementwise thy crls f vp)));*) - check_elementwise thy crls f vp))) - | Const ("Tools.UniversalList",_) => - Appl (Check_elementwise' (f, pred, (f,asm))) - | Const ("List.list.Nil",_) => - (*Notappl "not applicable to empty list" 3.6.03*) - Appl (Check_elementwise' (f, pred, (f,asm(*[] 11.6.03???*)))) - | _ => Notappl ("not applicable: "^(term2str f)^" should be constants") - end - - | applicable_in (p,p_) pt Or_to_List = - if member op = [Pbl,Met] p_ - then Notappl ((tac2str Or_to_List)^" not for pos "^(pos'2str (p,p_))) - else - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p; - in (let val ls = or2list f - in Appl (Or_to_List' (f, ls)) end) - handle _ => Notappl ("'Or_to_List' not applicable to "^(term2str f)) - end - - | applicable_in p pt (Collect_Trues) = - raise error ("applicable_in: not impl. for "^ - (tac2str (Collect_Trues))) - - | applicable_in p pt (Empty_Tac) = - Notappl "Empty_Tac is not applicable" - - | applicable_in (p,p_) pt (Tac id) = - let - val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p; - in case id of - "subproblem_equation_dummy" => - if is_expliceq f - then Appl (Tac_ (thy, term2str f, id, - "subproblem_equation_dummy ("^(term2str f)^")")) - else Notappl "applicable only to equations made explicit" - | "solve_equation_dummy" => - let (*val _= writeln("### applicable_in: solve_equation_dummy: f= " - ^f);*) - val (id',f') = split_dummy (term2str f); - (*val _= writeln("### applicable_in: f'= "^f');*) - (*val _= (term_of o the o (parse thy)) f';*) - (*val _= writeln"### applicable_in: solve_equation_dummy";*) - in if id' <> "subproblem_equation_dummy" then Notappl "no subproblem" - else if is_expliceq ((term_of o the o (parse thy)) f') - then Appl (Tac_ (thy, term2str f, id, "[" ^ f' ^ "]")) - else error ("applicable_in: f= " ^ f') end - | _ => Appl (Tac_ (thy, term2str f, id, term2str f)) end - - | applicable_in p pt End_Proof' = Appl End_Proof'' - - | applicable_in _ _ m = - raise error ("applicable_in called for "^(tac2str m)); - -(*WN060614 unused*) -fun tac2tac_ pt p m = - case applicable_in p pt m of - Appl (m') => m' - | Notappl _ => raise error ("tac2mstp': fails with"^ - (tac2str m)); - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/calchead.sml --- a/src/Tools/isac/ME/calchead.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2257 +0,0 @@ -(* Specify-phase: specifying and modeling a problem or a subproblem. The - most important types are declared in mstools.sml. - author: Walther Neuper - 991122 - (c) due to copyright terms - -use"ME/calchead.sml"; -use"calchead.sml"; -12345678901234567890123456789012345678901234567890123456789012345678901234567890 - 10 20 30 40 50 60 70 80 -*) - -(* TODO interne Funktionen aus sig entfernen *) -signature CALC_HEAD = - sig - datatype additm = Add of SpecifyTools.itm | Err of string - val all_dsc_in : SpecifyTools.itm_ list -> Term.term list - val all_modspec : ptree * pos' -> ptree * pos' - datatype appl = Appl of tac_ | Notappl of string - val appl_add : - theory -> - string -> - SpecifyTools.ori list -> - SpecifyTools.itm list -> - (string * (Term.term * Term.term)) list -> cterm' -> additm - type calcstate - type calcstate' - val chk_vars : term ppc -> string * Term.term list - val chktyp : - theory -> int * term list * term list -> term - val chktyps : - theory -> term list * term list -> term list - val complete_metitms : - SpecifyTools.ori list -> - SpecifyTools.itm list -> - SpecifyTools.itm list -> pat list -> SpecifyTools.itm list - val complete_mod_ : ori list * pat list * pat list * itm list -> - itm list * itm list - val complete_mod : ptree * pos' -> ptree * (pos * pos_) - val complete_spec : ptree * pos' -> ptree * pos' - val cpy_nam : - pat list -> preori list -> pat -> preori - val e_calcstate : calcstate - val e_calcstate' : calcstate' - val eq1 : ''a -> 'b * (''a * 'c) -> bool - val eq3 : - ''a -> Term.term -> 'b * 'c * 'd * ''a * SpecifyTools.itm_ -> bool - val eq4 : ''a -> 'b * ''a list * 'c * 'd * 'e -> bool - val eq5 : - 'a * 'b * 'c * 'd * SpecifyTools.itm_ -> - 'e * 'f * 'g * Term.term * 'h -> bool - val eq_dsc : SpecifyTools.itm * SpecifyTools.itm -> bool - val eq_pos' : ''a * pos_ -> ''a * pos_ -> bool - val f_mout : theory -> mout -> Term.term - val filter_outs : - SpecifyTools.ori list -> - SpecifyTools.itm list -> SpecifyTools.ori list - val filter_pbt : - SpecifyTools.ori list -> - ('a * (Term.term * 'b)) list -> SpecifyTools.ori list - val foldl1 : ('a * 'a -> 'a) -> 'a list -> 'a - val foldr1 : ('a * 'a -> 'a) -> 'a list -> 'a - val form : 'a -> ptree -> (string * ('a * pos_) * Term.term) list - val formres : 'a -> ptree -> (string * ('a * pos_) * Term.term) list - val gen_ins' : ('a * 'a -> bool) -> 'a * 'a list -> 'a list - val get_formress : - (string * (pos * pos_) * Term.term) list list -> - pos -> ptree list -> (string * (pos * pos_) * Term.term) list - val get_forms : - (string * (pos * pos_) * Term.term) list list -> - posel list -> ptree list -> (string * (pos * pos_) * Term.term) list - val get_interval : pos' -> pos' -> int -> ptree -> (pos' * term) list - val get_ocalhd : ptree * pos' -> ocalhd - val get_spec_form : tac_ -> pos' -> ptree -> mout - val geti_ct : - theory -> - SpecifyTools.ori -> SpecifyTools.itm -> string * cterm' - val getr_ct : theory -> SpecifyTools.ori -> string * cterm' - val has_list_type : Term.term -> bool - val header : pos_ -> pblID -> metID -> pblmet - val insert_ppc : - theory -> - int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ -> - SpecifyTools.itm list -> SpecifyTools.itm list - val insert_ppc' : - SpecifyTools.itm -> SpecifyTools.itm list -> SpecifyTools.itm list - val is_complete_mod : ptree * pos' -> bool - val is_complete_mod_ : SpecifyTools.itm list -> bool - val is_complete_modspec : ptree * pos' -> bool - val is_complete_spec : ptree * pos' -> bool - val is_copy_named : 'a * ('b * Term.term) -> bool - val is_copy_named_idstr : string -> bool - val is_error : SpecifyTools.itm_ -> bool - val is_field_correct : ''a -> ''b -> (''a * ''b list) list -> bool - val is_known : - theory -> - string -> - SpecifyTools.ori list -> - Term.term -> string * SpecifyTools.ori * Term.term list - val is_list_type : Term.typ -> bool - val is_notyet_input : - theory -> - SpecifyTools.itm list -> - Term.term list -> - SpecifyTools.ori -> - ('a * (Term.term * Term.term)) list -> string * SpecifyTools.itm - val is_parsed : SpecifyTools.itm_ -> bool - val is_untouched : SpecifyTools.itm -> bool - val matc : - theory -> - pat list -> - Term.term list -> - (int list * string * Term.term * Term.term list) list -> - (int list * string * Term.term * Term.term list) list - val match_ags : - theory -> pat list -> Term.term list -> SpecifyTools.ori list - val maxl : int list -> int - val match_ags_msg : string list -> Term.term -> Term.term list -> unit - val memI : ''a list -> ''a -> bool - val mk_additem : string -> cterm' -> tac - val mk_delete : theory -> string -> SpecifyTools.itm_ -> tac - val mtc : - theory -> pat -> Term.term -> SpecifyTools.preori option - val nxt_add : - theory -> - SpecifyTools.ori list -> - (string * (Term.term * 'a)) list -> - SpecifyTools.itm list -> (string * cterm') option - val nxt_model_pbl : tac_ -> ptree * (int list * pos_) -> tac_ - val nxt_spec : - pos_ -> - bool -> - SpecifyTools.ori list -> - spec -> - SpecifyTools.itm list * SpecifyTools.itm list -> - (string * (Term.term * 'a)) list * (string * (Term.term * 'b)) list -> - spec -> pos_ * tac - val nxt_specif : tac -> ptree * (int list * pos_) -> calcstate' - val nxt_specif_additem : - string -> cterm' -> ptree * (int list * pos_) -> calcstate' - val nxt_specify_init_calc : fmz -> calcstate - val ocalhd_complete : - SpecifyTools.itm list -> - (bool * Term.term) list -> domID * pblID * metID -> bool - val ori2Coritm : - pat list -> ori -> itm - val ori_2itm : - 'a -> - SpecifyTools.itm_ -> - Term.term -> Term.term list -> SpecifyTools.ori -> SpecifyTools.itm - val overwrite_ppc : - theory -> - int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ -> - SpecifyTools.itm list -> - (int * SpecifyTools.vats * bool * string * SpecifyTools.itm_) list - val parse_ok : SpecifyTools.itm_ list -> bool - val posform2str : pos' * ptform -> string - val posforms2str : (pos' * ptform) list -> string - val posterms2str : (pos' * term) list -> string (*tests only*) - val ppc135list : 'a SpecifyTools.ppc -> 'a list - val ppc2list : 'a SpecifyTools.ppc -> 'a list - val pt_extract : - ptree * (int list * pos_) -> - ptform * tac option * Term.term list - val pt_form : ppobj -> ptform - val pt_model : ppobj -> pos_ -> ptform - val reset_calchead : ptree * pos' -> ptree * pos' - val seek_oridts : - theory -> - string -> - Term.term * Term.term list -> - (int * SpecifyTools.vats * string * Term.term * Term.term list) list - -> string * SpecifyTools.ori * Term.term list - val seek_orits : - theory -> - string -> - Term.term list -> - (int * SpecifyTools.vats * string * Term.term * Term.term list) list - -> string * SpecifyTools.ori * Term.term list - val seek_ppc : - int -> SpecifyTools.itm list -> SpecifyTools.itm option - val show_pt : ptree -> unit - val some_spec : spec -> spec -> spec - val specify : - tac_ -> - pos' -> - cid -> - ptree -> - (posel list * pos_) * ((posel list * pos_) * istate) * mout * tac * - safe * ptree - val specify_additem : - string -> - cterm' * 'a -> - int list * pos_ -> - 'b -> - ptree -> - (pos * pos_) * ((pos * pos_) * istate) * mout * tac * safe * ptree - val tag_form : theory -> term * term -> term - val test_types : theory -> Term.term * Term.term list -> string - val typeless : Term.term -> Term.term - val unbound_ppc : term SpecifyTools.ppc -> Term.term list - val vals_of_oris : SpecifyTools.ori list -> Term.term list - val variants_in : Term.term list -> int - val vars_of_pbl_ : ('a * ('b * Term.term)) list -> Term.term list - val vars_of_pbl_' : ('a * ('b * Term.term)) list -> Term.term list - end - - - - - -(*---------------------------------------------------------------------*) -structure CalcHead (**): CALC_HEAD(**) = - -struct -(*---------------------------------------------------------------------*) - -(* datatypes *) - -(*.the state wich is stored after each step of calculation; it contains - the calc-state and a list of [tac,istate](="tacis") to be applied. - the last_elem tacis is the first to apply to the calc-state and - the (only) one shown to the front-end as the 'proposed tac'. - the calc-state resulting from the application of tacis is not stored, - because the tacis hold enought information for efficiently rebuilding - this state just by "fun generate ".*) -type calcstate = - (ptree * pos') * (*the calc-state to which the tacis could be applied*) - (taci list); (*ev. several (hidden) steps; - in REVERSE order: first tac_ to apply is last_elem*) -val e_calcstate = ((EmptyPtree, e_pos'), [e_taci]):calcstate; - -(*the state used during one calculation within the mathengine; it contains - a list of [tac,istate](="tacis") which generated the the calc-state; - while this state's tacis are extended by each (internal) step, - the calc-state is used for creating new nodes in the calc-tree - (eg. applicable_in requires several particular nodes of the calc-tree) - and then replaced by the the newly created; - on leave of the mathengine the resuing calc-state is dropped anyway, - because the tacis hold enought information for efficiently rebuilding - this state just by "fun generate ".*) -type calcstate' = - taci list * (*cas. several (hidden) steps; - in REVERSE order: first tac_ to apply is last_elem*) - pos' list * (*a "continuous" sequence of pos', - deleted by application of taci list*) - (ptree * pos'); (*the calc-state resulting from the application of tacis*) -val e_calcstate' = ([e_taci], [e_pos'], (EmptyPtree, e_pos')):calcstate'; - -(*FIXXXME.WN020430 intermediate hack for fun ass_up*) -fun f_mout thy (Form' (FormKF (_,_,_,_,f))) = (term_of o the o (parse thy)) f - | f_mout thy _ = raise error "f_mout: not called with formula"; - - -(*.is the calchead complete ?.*) -fun ocalhd_complete (its: itm list) (pre: (bool * term) list) (dI,pI,mI) = - foldl and_ (true, map #3 its) andalso - foldl and_ (true, map #1 pre) andalso - dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID; - - -(* make a term 'typeless' for comparing with another 'typeless' term; - 'type-less' usually is illtyped *) -fun typeless (Const(s,_)) = (Const(s,e_type)) - | typeless (Free(s,_)) = (Free(s,e_type)) - | typeless (Var(n,_)) = (Var(n,e_type)) - | typeless (Bound i) = (Bound i) - | typeless (Abs(s,_,t)) = Abs(s,e_type, typeless t) - | typeless (t1 $ t2) = (typeless t1) $ (typeless t2); -(* -> val (SOME ct) = parse thy "max_relation (A=#2*a*b - a^^^#2)"; -> val (_,t1) = split_dsc_t hs (term_of ct); -> val (SOME ct) = parse thy "A=#2*a*b - a^^^#2"; -> val (_,t2) = split_dsc_t hs (term_of ct); -> typeless t1 = typeless t2; -val it = true : bool -*) - - - -(*.to an input (d,ts) find the according ori and insert the ts.*) -(*WN.11.03: + dont take first inter<>[]*) -fun seek_oridts thy sel (d,ts) [] = - ("'"^(Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))^ - "' not found (typed)", (0,[],sel,d,ts):ori, []) - (* val (id,vat,sel',d',ts')::oris = ori; - val (id,vat,sel',d',ts') = ori; - *) - | seek_oridts thy sel (d,ts) ((id,vat,sel',d',ts')::(oris:ori list)) = - if sel = sel' andalso d=d' andalso (inter op = ts ts') <> [] - then if sel = sel' - then ("", - (id,vat,sel,d, inter op = ts ts'):ori, - ts') - else ((Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts))) - ^ " not for " ^ sel, - e_ori_, - []) - else seek_oridts thy sel (d,ts) oris; - -(*.to an input (_,ts) find the according ori and insert the ts.*) -fun seek_orits thy sel ts [] = - ("'"^ - (strs2str (map (Syntax.string_of_term (thy2ctxt thy)) ts))^ - "' not found (typed)", e_ori_, []) - | seek_orits thy sel ts ((id,vat,sel',d,ts')::(oris:ori list)) = - if sel = sel' andalso (inter op = ts ts') <> [] - then if sel = sel' - then ("", - (id,vat,sel,d, inter op = ts ts'):ori, - ts') - else (((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts) - ^ " not for "^sel, - e_ori_, - []) - else seek_orits thy sel ts oris; -(* false -> val ((id,vat,sel',d,ts')::(ori':ori)) = ori; -> seek_orits thy sel ts [(id,vat,sel',d,ts')]; -uncaught exception TYPE -> seek_orits thy sel ts []; -uncaught exception TYPE -*) - -(*find_first item with #1 equal to id*) -fun seek_ppc id [] = NONE - | seek_ppc id (p::(ppc:itm list)) = - if id = #1 p then SOME p else seek_ppc id ppc; - - - -(*---------------------------------------------(3) nach ptyps.sml 23.3.02*) - - -datatype appl = Appl of tac_ | Notappl of string; - -fun ppc2list ({Given=gis,Where=whs,Find=fis, - With=wis,Relate=res}: 'a ppc) = - gis @ whs @ fis @ wis @ res; -fun ppc135list ({Given=gis,Find=fis,Relate=res,...}: 'a ppc) = - gis @ fis @ res; - - - - -(* get the number of variants in a problem in 'original', - assumes equal descriptions in immediate sequence *) -fun variants_in ts = - let fun eq(x,y) = head_of x = head_of y; - fun cnt eq [] y n = ([n],[]) - | cnt eq (x::xs) y n = if eq(x,y) then cnt eq xs y (n+1) - else ([n], x::xs); - fun coll eq xs [] = xs - | coll eq xs (y::ys) = - let val (n,ys') = cnt eq (y::ys) y 0; - in if ys' = [] then xs @ n else coll eq (xs @ n) ys' end; - val vts = subtract op = [1] (distinct (coll eq [] ts)); - in case vts of [] => 1 | [n] => n - | _ => error "different variants in formalization" end; -(* -> cnt (op=) [2,2,2,4,5,5,5,5,5] 2 0; -val it = ([3],[4,5,5,5,5,5]) : int list * int list -> coll (op=) [] [1,2,2,2,4,5,5,5,5,5]; -val it = [1,3,1,5] : int list -*) - -fun is_list_type (Type("List.list",_)) = true - | is_list_type _ = false; -(* fun destr (Type(str,sort)) = (str,sort); -> val (SOME ct) = parse thy "lll::real list"; -> val ty = (#T o rep_cterm) ct; -> is_list_type ty; -val it = true : bool -> destr ty; -val it = ("List.list",["RealDef.real"]) : string * typ list -> atomty ((#t o rep_cterm) ct); -*** ------------- -*** Free ( lll, real list) -val it = () : unit - -> val (SOME ct) = parse thy "[lll::real]"; -> val ty = (#T o rep_cterm) ct; -> is_list_type ty; -val it = true : bool -> destr ty; -val it = ("List.list",["'a"]) : string * typ list -> atomty ((#t o rep_cterm) ct); -*** ------------- -*** Const ( List.list.Cons, [real, real list] => real list) -*** Free ( lll, real) -*** Const ( List.list.Nil, real list) - -> val (SOME ct) = parse thy "lll"; -> val ty = (#T o rep_cterm) ct; -> is_list_type ty; -val it = false : bool *) - - -fun has_list_type (Free(_,T)) = is_list_type T - | has_list_type _ = false; -(* -> val (SOME ct) = parse thy "lll::real list"; -> has_list_type (term_of ct); -val it = true : bool -> val (SOME ct) = parse thy "[lll::real]"; -> has_list_type (term_of ct); -val it = false : bool *) - -fun is_parsed (Syn _) = false - | is_parsed _ = true; -fun parse_ok its = foldl and_ (true, map is_parsed its); - -fun all_dsc_in itm_s = - let - fun d_in (Cor ((d,_),_)) = [d] - | d_in (Syn c) = [] - | d_in (Typ c) = [] - | d_in (Inc ((d,_),_)) = [d] - | d_in (Sup (d,_)) = [d] - | d_in (Mis (d,_)) = [d]; - in (flat o (map d_in)) itm_s end; - -(* 30.1.00 --- -fun is_Syn (Syn _) = true - | is_Syn (Typ _) = true - | is_Syn _ = false; - --- *) -fun is_error (Cor (_,ts)) = false - | is_error (Sup (_,ts)) = false - | is_error (Inc (_,ts)) = false - | is_error (Mis (_,ts)) = false - | is_error _ = true; - -(* 30.1.00 --- -fun ct_in (Syn (c)) = c - | ct_in (Typ (c)) = c - | ct_in _ = raise error "ct_in called for Cor .. Sup"; - --- *) - -(*#############################################################*) -(*#############################################################*) -(* vvv--- aus nnewcode.sml am 30.1.00 ---vvv *) - - -(* testdaten besorgen: - use"test-coil-kernel.sml"; - val (PblObj{origin=(oris,_,_),meth={ppc=itms,...},...}) = - get_obj I pt p; - *) - -(* given oris, ppc, - variant V: oris union ppc => int, id ID: oris union ppc => int - - ppc is_complete == - EX vt:V. ALL r:oris --> EX i:ppc. ID r = ID i & complete i - - and - @vt = max sum(i : ppc) V i -*) - - - -(* -> ((vts_cnt (vts_in itms))) itms; - - - ----^^--test 10.3. -> val vts = vts_in itms; -val vts = [1,2,3] : int list -> val nvts = vts_cnt vts itms; -val nvts = [(1,6),(2,5),(3,7)] : (int * int) list -> val mx = max2 nvts; -val mx = (3,7) : int * int -> val v = max_vt itms; -val v = 3 : int --------------------------- -> -*) - -(*.get the first term in ts from ori.*) -(* val (_,_,fd,d,ts) = hd miss; - *) -fun getr_ct thy ((_,_,fd,d,ts):ori) = - (fd, ((Syntax.string_of_term (thy2ctxt thy)) o - (comp_dts thy)) (d,[hd ts]):cterm'); -(* val t = comp_dts thy (d,[hd ts]); - *) - -(* get a term from ori, notyet input in itm *) -fun geti_ct thy ((_,_,_,d,ts):ori) ((_,_,_,fd,itm_):itm) = - (fd, ((Syntax.string_of_term (thy2ctxt thy)) o (comp_dts thy)) - (d, subtract op = (ts_in itm_) ts):cterm'); -(* test-maximum.sml fmy <> [], Init_Proof ... - val (_,_,_,d,ts) = ori; val (_,_,_,fd,itm_) = hd icl; - val d' $ ts' = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]"; - atomty d; - atomty d'; - atomty (hd ts); - atomty ts'; - cterm_of thy (d $ (hd ts)); - cterm_of thy (d' $ ts'); - - comp_dts thy (d,ts); - *) - - -(* in FE dsc, not dat: this is in itms ...*) -fun is_untouched ((_,_,false,_,Inc((_,[]),_)):itm) = true - | is_untouched _ = false; - - -(* select an item in oris, notyet input in itms - (precondition: in itms are only Cor, Sup, Inc) *) -local infix mem; -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun nxt_add thy ([]:ori list) pbt itms = (*root (only) ori...fmz=[]*) - let - fun test_d d ((i,_,_,_,itm_):itm) = (d = (d_in itm_)) andalso i<>0; - fun is_elem itms (f,(d,t)) = - case find_first (test_d d) itms of - SOME _ => true | NONE => false; - in case filter_out (is_elem itms) pbt of -(* val ((f,(d,_))::itms) = filter_out (is_elem itms) pbt; - *) - (f,(d,_))::itms => - SOME (f:string, ((Syntax.string_of_term (thy2ctxt thy)) o comp_dts thy) (d,[]):cterm') - | _ => NONE end - -(* val (thy,itms) = (assoc_thy (if dI=e_domID then dI' else dI),pbl); - *) - | nxt_add thy oris pbt itms = - let - fun testr_vt v ori = (curry (op mem) v) (#2 (ori:ori)) - andalso (#3 ori) <>"#undef"; - fun testi_vt v itm = (curry (op mem) v) (#2 (itm:itm)); - fun test_id ids r = curry (op mem) (#1 (r:ori)) ids; -(* val itm = hd icl; val (_,_,_,d,ts) = v6; - *) - fun test_subset (itm:itm) ((_,_,_,d,ts):ori) = - (d_in (#5 itm)) = d andalso subset op = (ts_in (#5 itm), ts); - fun false_and_not_Sup((i,v,false,f,Sup _):itm) = false - | false_and_not_Sup (i,v,false,f, _) = true - | false_and_not_Sup _ = false; - - val v = if itms = [] then 1 else max_vt itms; - val vors = if v = 0 then oris else filter (testr_vt v) oris;(*oris..vat*) - val vits = if v = 0 then itms (*because of dsc without dat*) - else filter (testi_vt v) itms; (*itms..vat*) - val icl = filter false_and_not_Sup vits; (* incomplete *) - in if icl = [] - then case filter_out (test_id (map #1 vits)) vors of - [] => NONE - (* val miss = filter_out (test_id (map #1 vits)) vors; - *) - | miss => SOME (getr_ct thy (hd miss)) - else - case find_first (test_subset (hd icl)) vors of - (* val SOME ori = find_first (test_subset (hd icl)) vors; - *) - NONE => raise error "nxt_add: EX itm. not(dat(itm)<=dat(ori))" - | SOME ori => SOME (geti_ct thy ori (hd icl)) - end -end; - - - -fun mk_delete thy "#Given" itm_ = Del_Given (itm_out thy itm_) - | mk_delete thy "#Find" itm_ = Del_Find (itm_out thy itm_) - | mk_delete thy "#Relate" itm_ = Del_Relation(itm_out thy itm_) - | mk_delete thy str _ = - raise error ("mk_delete: called with field '"^str^"'"); -fun mk_additem "#Given" ct = Add_Given ct - | mk_additem "#Find" ct = Add_Find ct - | mk_additem "#Relate"ct = Add_Relation ct - | mk_additem str _ = - raise error ("mk_additem: called with field '"^str^"'"); - - - - - -(* find the next tac in specify (except nxt_model_pbl) - 4.00.: TODO: do not return a pos !!! - (sind from DG comes the _OLD_ writepos)*) -(* -> val (pbl,pbt,mpc) =(pbl',get_pbt cpI,(#ppc o get_met) cmI); -> val (dI,pI,mI) = empty_spec; -> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*)) - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec); - -at Init_Proof: -> val met = [];val (pbt,mpc) = (get_pbt pI',(#ppc o get_met) mI'); -> val (dI,pI,mI) = empty_spec; -> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*)) - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec); - *) - -(*. determine the next step of specification; - not done here: Refine_Tacitly (otherwise *** unknown method: (..., no_met)) -eg. in rootpbl 'no_met': -args: - preok predicates are _all_ ok, or problem matches completely - oris immediately from formalization - (dI',pI',mI') specification coming from author/parent-problem - (pbl, item lists specified by user - met) -"-, tacitly completed by copy_probl - (dI,pI,mI) specification explicitly done by the user - (pbt, mpc) problem type, guard of method -.*) -(* val (preok,pbl,pbt,mpc)=(pb,pbl',(#ppc o get_pbt) cpI,(#ppc o get_met) cmI); - val (preok,pbl,pbt,mpc)=(pb,pbl',ppc,(#ppc o get_met) cmI); - val (Pbl, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) = - (p_, pb, oris, (dI',pI',mI'), (probl,meth), - (ppc, (#ppc o get_met) cmI), (dI,pI,mI)); - *) -fun nxt_spec Pbl preok (oris:ori list) ((dI',pI',mI'):spec) - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec) = - ((*writeln"### nxt_spec Pbl";*) - if dI'=e_domID andalso dI=e_domID then (Pbl, Specify_Theory dI') - else if pI'=e_pblID andalso pI=e_pblID then (Pbl, Specify_Problem pI') - else case find_first (is_error o #5) (pbl:itm list) of - SOME (_,_,_,fd,itm_) => - (Pbl, mk_delete - (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_) - | NONE => - ((*writeln"### nxt_spec is_error NONE";*) - case nxt_add (assoc_thy (if dI=e_domID then dI' else dI)) - oris pbt pbl of -(* val SOME (fd,ct') = nxt_add (assoc_thy (if dI=e_domID then dI' else dI)) - oris pbt pbl; - *) - SOME (fd,ct') => ((*writeln"### nxt_spec nxt_add SOME";*) - (Pbl, mk_additem fd ct')) - | NONE => (*pbl-items complete*) - if not preok then (Pbl, Refine_Problem pI') - else - if dI = e_domID then (Pbl, Specify_Theory dI') - else if pI = e_pblID then (Pbl, Specify_Problem pI') - else if mI = e_metID then (Pbl, Specify_Method mI') - else - case find_first (is_error o #5) met of - SOME (_,_,_,fd,itm_) => - (Met, mk_delete (assoc_thy dI) fd itm_) - | NONE => - (case nxt_add (assoc_thy dI) oris mpc met of - SOME (fd,ct') => (*30.8.01: pre?!?*) - (Met, mk_additem fd ct') - | NONE => - ((*Solv 3.4.00*)Met, Apply_Method mI)))) -(* val preok=pb; val (pbl, met) = (pbl,met'); - val (pbt,mpc)=((#ppc o get_pbt) cpI,(#ppc o get_met) cmI); - val (Met, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) = - (p_, pb, oris, (dI',pI',mI'), (probl,meth), - (ppc, (#ppc o get_met) cmI), (dI,pI,mI)); - *) - | nxt_spec Met preok oris (dI',pI',mI') (pbl, met) (pbt,mpc) (dI,pI,mI) = - ((*writeln"### nxt_spec Met"; *) - case find_first (is_error o #5) met of - SOME (_,_,_,fd,itm_) => - (Met, mk_delete (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_) - | NONE => - case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))oris mpc met of - SOME (fd,ct') => (Met, mk_additem fd ct') - | NONE => - ((*writeln"### nxt_spec Met: nxt_add NONE";*) - if dI = e_domID then (Met, Specify_Theory dI') - else if pI = e_pblID then (Met, Specify_Problem pI') - else if not preok then (Met, Specify_Method mI) - else (Met, Apply_Method mI))); - -(* di_ pI_ mI_ pos_ -val itms = [(1,[1],true,"#Find",Cor(e_term,[e_term])):itm, - (2,[2],true,"#Find",Syn("empty"))]; -*) - - -(* ^^^--- aus nnewcode.sml am 30.1.00 ---^^^ *) -(*#############################################################*) -(*#############################################################*) -(* vvv--- aus nnewcode.sml vor 29.1.00 ---vvv *) - -(*3.3.-- -fun update_itm (cl,d,ts) ((id,vt,_,sl,Cor (_,_)):itm) = - (id,vt,cl,sl,Cor (d,ts)):itm - | update_itm (cl,d,ts) (id,vt,_,sl,Syn (_)) = - raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^ - " not not for Syn (s:cterm')") - | update_itm (cl,d,ts) (id,vt,_,sl,Typ (_)) = - raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^ - " not not for Typ (s:cterm')") - | update_itm (cl,d,ts) (id,vt,_,sl,Fal (_,_)) = - (id,vt,cl,sl,Fal (d,ts)) - | update_itm (cl,d,ts) (id,vt,_,sl,Inc (_,_)) = - (id,vt,cl,sl,Inc (d,ts)) - | update_itm (cl,d,ts) (id,vt,_,sl,Sup (_,_)) = - (id,vt,cl,sl,Sup (d,ts)); -*) - - - - -fun is_field_correct sel d dscpbt = - case assoc (dscpbt, sel) of - NONE => false - | SOME ds => member op = ds d; - -(*. update the itm_ already input, all..from ori .*) -(* val (id,vt,fd,d,ts) = (i,v,f,d,ts\\ts'); - *) -fun ori_2itm thy itm_ pid all ((id,vt,fd,d,ts):ori) = - let - val ts' = union op = (ts_in itm_) ts; - val pval = pbl_ids' thy d ts' - (*WN.9.5.03: FIXXXME [#0, epsilon] - here would upd_penv be called for [#0, epsilon] etc. *) - val complete = if eq_set op = (ts', all) then true else false; - in case itm_ of - (Cor _) => - (if fd = "#undef" then (id,vt,complete,fd,Sup(d,ts')) - else (id,vt,complete,fd,Cor((d,ts'),(pid, pval)))):itm - | (Syn c) => raise error ("ori_2itm wants to overwrite "^c) - | (Typ c) => raise error ("ori_2itm wants to overwrite "^c) - | (Inc _) => if complete - then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval))) - else (id,vt,false,fd, Inc ((d,ts'),(pid, pval))) - | (Sup ((*_,_*)d,ts')) => (*4.9.01 lost env*) - (*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts')) - (*else (id,vt,complete,fd,Cor((d,ts'),e))*) -(* 28.1.00: not completely clear ---^^^ etc.*) -(* 4.9.01: Mis just copied---vvv *) - | (Mis _) => if complete - then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval))) - else (id,vt,false,fd, Inc ((d,ts'),(pid, pval))) - end; - - -fun eq1 d (_,(d',_)) = (d = d'); -fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_); - - -(* 'all' ts from ori; ts is the input; (ori carries rest of info) - 9.01: this + ori_2itm is _VERY UNCLEAR_ ? overhead ? - pval: value for problem-environment _NOT_ checked for 'inter' -- - -- FIXXME.WN.11.03 the generation of penv has to go to insert_ppc - (as it has been done for input_icalhd+insert_ppc' in 11.03)*) -(*. is_input ori itms <=> - EX itm. (1) ori(field,dsc) = itm(field,dsc) & (2..4) - (2) ori(ts) subset itm(ts) --- Err "already input" - (3) ori(ts) inter itm(ts) = empty --- new: ori(ts) - (4) -"- <> empty --- new: ori(ts) \\ inter .*) -(* val(itms,(i,v,f,d,ts)) = (ppc,ori'); - *) -fun is_notyet_input thy (itms:itm list) all ((i,v,f,d,ts):ori) pbt = - case find_first (eq1 d) pbt of - SOME (_,(_,pid)) =>(* val SOME (_,(_,pid)) = find_first (eq1 d) pbt; - val SOME (_,_,_,_,itm_)=find_first (eq3 f d) itms; - *) - (case find_first (eq3 f d) itms of - SOME (_,_,_,_,itm_) => - let - val ts' = inter op = (ts_in itm_) ts; - in if subset op = (ts, ts') - then (((strs2str' o - map (Syntax.string_of_term (thy2ctxt thy))) ts')^ - " already input", e_itm) (*2*) - else ("", - ori_2itm thy itm_ pid all (i,v,f,d, - subtract op = ts' ts)) (*3,4*) - end - | NONE => ("", ori_2itm thy (Inc ((e_term,[]),(pid,[]))) - pid all (i,v,f,d,ts)) (*1*) - ) - | NONE => ("", ori_2itm thy (Sup (d,ts)) - e_term all (i,v,f,d,ts)); - -fun test_types thy (d,ts) = - let - val s = !show_types; val _ = show_types:= true; - val opt = (try (comp_dts thy)) (d,ts); - val msg = case opt of - SOME _ => "" - | NONE => ((Syntax.string_of_term (thy2ctxt thy) d)^" "^ - ((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts) - ^ " is illtyped"); - val _ = show_types:= s - in msg end; - - - -fun maxl [] = raise error "maxl of []" - | maxl (y::ys) = - let fun mx x [] = x - | mx x (y::ys) = if x < (y:int) then mx y ys else mx x ys - in mx y ys end; - - -(*. is the input term t known in oris ? - give feedback on all(?) strange input; - return _all_ terms already input to this item (e.g. valuesFor a,b) .*) -(*WN.11.03: from lists*) -fun is_known thy sel ori t = -(* val (ori,t)=(oris,term_of ct); - *) - let - val ots = (distinct o flat o (map #5)) (ori:ori list); - val oids = ((map (fst o dest_Free)) o distinct o - flat o (map vars)) ots; - val (d,ts(*,pval*)) = split_dts thy t; - val ids = map (fst o dest_Free) - ((distinct o (flat o (map vars))) ts); - in if (subtract op = oids ids) <> [] - then (("identifiers "^(strs2str' (subtract op = oids ids))^ - " not in example"), e_ori_, []) - else - if d = e_term - then - if not (subset op = (map typeless ts, map typeless ots)) - then (("terms '"^ - ((strs2str' o (map (Syntax.string_of_term - (thy2ctxt thy)))) ts)^ - "' not in example (typeless)"), e_ori_, []) - else (case seek_orits thy sel ts ori of - ("", ori_ as (_,_,_,d,ts), all) => - (case test_types thy (d,ts) of - "" => ("", ori_, all) - | msg => (msg, e_ori_, [])) - | (msg,_,_) => (msg, e_ori_, [])) - else - if member op = (map #4 ori) d - then seek_oridts thy sel (d,ts) ori - else ((Syntax.string_of_term (thy2ctxt thy) d)^ - (*" not in example", e_ori_, []) ///11.11.03*) - " not in example", (0,[],sel,d,ts), []) - end; - - -(*. for return-value of appl_add .*) -datatype additm = - Add of itm - | Err of string; (*error-message*) - - -(*. add an item; check wrt. oris and pbt .*) - -(* in contrary to oris<>[] below, this part handles user-input - extremely acceptive, i.e. accept input instead error-msg *) -fun appl_add thy sel ([]:ori list) ppc pbt ct' = -(* val (ppc,pbt,ct',env) = (pbl, (#ppc o get_pbt) cpI, ct, []:envv); - !!!! 28.8.01: env tested _minimally_ !!! - *) - let - val i = 1 + (if ppc=[] then 0 else maxl (map #1 ppc)); - in case parse thy ct' of (*should be done in applicable_in 4.00.FIXME*) - NONE => Add (i,[],false,sel,Syn ct') -(* val (SOME ct) = parse thy ct'; - *) - | SOME ct => - let - val (d,ts(*,pval*)) = split_dts thy (term_of ct); - in if d = e_term - then Add (i,[],false,sel,Mis (dsc_unknown,hd ts(*24.3.02*))) - - else - (case find_first (eq1 d) pbt of - NONE => Add (i,[],true,sel,Sup ((d,ts))) - | SOME (f,(_,id)) => -(* val SOME (f,(_,id)) = find_first (eq1 d) pbt; - *) - let - fun eq2 d ((i,_,_,_,itm_):itm) = - (d = (d_in itm_)) andalso i<>0; - in case find_first (eq2 d) ppc of - NONE => Add (i,[],true,f, Cor ((d,ts), (id, (*pval*) - pbl_ids' thy d ts))) - | SOME (i',_,_,_,itm_) => -(* val SOME (i',_,_,_,itm_) = find_first (eq2 d) ppc; - val NONE = find_first (eq2 d) ppc; - *) - if is_list_dsc d - then let val ts = union op = ts (ts_in itm_) - in Add (if ts_in itm_ = [] then i else i', - [],true,f,Cor ((d, ts), (id, (*pval*) - pbl_ids' thy d ts))) - end - else Add (i',[],true,f,Cor ((d,ts),(id, (*pval*) - pbl_ids' thy d ts))) - end - ) - end - end -(*. add ct to ppc .*) -(*FIXXME: accept items as Sup, Syn here, too (like appl_add..oris=[] above)*) -(* val (ppc,pbt) = (pbl, ppc); - val (ppc,pbt) = (met, (#ppc o get_met) cmI); - - val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI); - *) - | appl_add thy sel oris ppc pbt(*only for upd_envv*) ct = - let - val ctopt = parse thy ct; - in case ctopt of - NONE => Err ("syntax error in "^ct) - | SOME ct =>(* val SOME ct = ctopt; - val (msg,ori',all) = is_known thy sel oris (term_of ct); - val (msg,itm) = is_notyet_input thy ppc all ori' pbt; - *) - (case is_known thy sel oris (term_of ct) of - ("",ori'(*ts='ct'*), all) => - (case is_notyet_input thy ppc all ori' pbt of - ("",itm) => Add itm - | (msg,_) => Err msg) - | (msg,_,_) => Err msg) - end; -(* -> val (msg,itm) = is_notyet_input thy ppc all ori'; -val itm = (12,[3],false,"#Relate",Cor (Const #,[#,#])) : itm -> val itm_ = #5 itm; -> val ts = ts_in itm_; -> map (atomty) ts; -*) - -(*---------------------------------------------(4) nach ptyps.sml 23.3.02*) - - -(** make oris from args of the stac SubProblem and from pbt **) - -(*.can this formal argument (of a model-pattern) be omitted in the arg-list - of a SubProblem ? see ME/ptyps.sml 'type met '.*) -fun is_copy_named_idstr str = - case (rev o explode) str of - "_"::_::"_"::_ => true - | _ => false; -(*> is_copy_named_idstr "v_i_"; -val it = true : bool - > is_copy_named_idstr "e_"; -val it = false : bool - > is_copy_named_idstr "L___"; -val it = true : bool -*) -(*.should this formal argument (of a model-pattern) create a new identifier?.*) -fun is_copy_named_generating_idstr str = - if is_copy_named_idstr str - then case (rev o explode) str of - "_"::"_"::"_"::_ => false - | _ => true - else false; -(*> is_copy_named_generating_idstr "v_i_"; -val it = true : bool - > is_copy_named_generating_idstr "L___"; -val it = false : bool -*) - -(*.can this formal argument (of a model-pattern) be omitted in the arg-list - of a SubProblem ? see ME/ptyps.sml 'type met '.*) -fun is_copy_named (_,(_,t)) = (is_copy_named_idstr o free2str) t; -(*.should this formal argument (of a model-pattern) create a new identifier?.*) -fun is_copy_named_generating (_,(_,t)) = - (is_copy_named_generating_idstr o free2str) t; - - -(*.split type-wrapper from scr-arg and build part of an ori; - an type-error is reported immediately, raises an exn, - subsequent handling of exn provides 2nd part of error message.*) -(*fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = WN100820 made cterm to term - (* val (thy, (str, (dsc, _)), (ty $ var)) = - (thy, p, a); - *) - (cterm_of thy (dsc $ var);(*type check*) - SOME ((([1], str, dsc, (*[var]*) - split_dts' (dsc, var))): preori)(*:ori without leading #*)) - handle e as TYPE _ => - (writeln (dashs 70^"\n" - ^"*** ERROR while creating the items for the model of the ->problem\n" - ^"*** from the ->stac with ->typeconstructor in arglist:\n" - ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n" - ^"*** description: "^(term_detail2str dsc) - ^"*** value: "^(term_detail2str var) - ^"*** typeconstructor in script: "^(term_detail2str ty) - ^"*** checked by theory: "^(theory2str thy)^"\n" - ^"*** "^dots 66); - print_exn e; (*raises exn again*) - NONE);*) -fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = - (* val (thy, (str, (dsc, _)), (ty $ var)) = - (thy, p, a); - *) - (cterm_of thy (dsc $ var);(*type check*) - SOME ((([1], str, dsc, (*[var]*) - split_dts' (dsc, var))): preori)(*:ori without leading #*)) - handle e as TYPE _ => - (writeln (dashs 70^"\n" - ^"*** ERROR while creating the items for the model of the ->problem\n" - ^"*** from the ->stac with ->typeconstructor in arglist:\n" - ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n" - ^"*** description: "^(term_detail2str dsc) - ^"*** value: "^(term_detail2str var) - ^"*** typeconstructor in script: "^(term_detail2str ty) - ^"*** checked by theory: "^(theory2str thy)^"\n" - ^"*** "^dots 66); - (*WN100820 postponed: print_exn e; raises exn again*) - NONE); -(*> val pbt = (#ppc o get_pbt) ["univariate","equation"]; -> val Const ("Script.SubProblem",_) $ - (Const ("Pair",_) $ Free (thy', _) $ - (Const ("Pair",_) $ pblID' $ metID')) $ ags = - str2term"(SubProblem (SqRoot_,[univariate,equation],\ - \[SqRoot_,solve_linear]) [bool_ (x+1- 2=0), real_ x])::bool list"; -> val ags = isalist2list ags; -> mtc thy (hd pbt) (hd ags); -val it = SOME ([1],"#Given",Const (#,#),[# $ #]) *) - -(*.match each pat of the model-pattern with an actual argument; - precondition: copy-named vars are filtered out.*) -fun matc thy ([]:pat list) _ (oris:preori list) = oris - | matc thy pbt [] _ = - (writeln (dashs 70); - raise error ("actual arg(s) missing for '"^pats2str pbt - ^"' i.e. should be 'copy-named' by '*_._'")) - | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris = - (* val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) = - (thy, pbt', ags, []); - (*recursion..*) - val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) = - (thy, pbt, ags, (oris @ [ori])); - *) - (*del?..*)if (is_copy_named_idstr o free2str) t then oris - else(*..del?*) let val opt = mtc thy p a; - in case opt of - (* val SOME ori = mtc thy p a; - *) - SOME ori => matc thy pbt ags (oris @ [ori]) - | NONE => [](*WN050903 skipped by exn handled in match_ags*) - end; -(* run subp-rooteq.sml until Init_Proof before ... -> val Nd (PblObj {origin=(oris,_,_),...},_) = pt;(*from test/subp-rooteq.sml*) -> fun xxxfortest (_,a,b,c,d) = (a,b,c,d);val oris = map xxxfortest oris; - - other vars as in mtc .. -> matc thy (drop_last pbt) ags []; -val it = ([[1],"#Given",Const #,[#]),(0,[#],"#Given",Const #,[#])],2)*) - - -(*WN051014 outcommented with redesign copy-named (for omitting '#Find' - in SubProblem); - kept as initial idea for generating x_1, x_2, ... for equations*) -fun cpy_nam (pbt:pat list) (oris:preori list) (p as (field,(dsc,t)):pat) = -(* val ((pbt:pat list), (oris:preori list), ((field,(dsc,t)):pat)) = - (pbt', oris', hd (*!!!!!*) cy); - *) - (if is_copy_named_generating p - then (*WN051014 kept strange old code ...*) - let fun sel (_,_,d,ts) = comp_ts (d, ts) - val cy' = (implode o drop_last o drop_last o explode o free2str) t - val ext = (last_elem o drop_last o explode o free2str) t - val vars' = map (free2str o snd o snd) pbt(*cpy-nam filtered_out*) - val vals = map sel oris - val cy_ext = (free2str o the) (assoc (vars'~~vals, cy'))^"_"^ext - in ([1], field, dsc, [mk_free (type_of t) cy_ext]):preori end - else ([1], field, dsc, [t]) - ) - handle _ => raise error ("cpy_nam: for "^(term2str t)); - -(*> val (field,(dsc,t)) = last_elem pbt; -> cpy_nam pbt (drop_last oris) (field,(dsc,t)); -val it = ([1],"#Find", - Const ("Descript.solutions","bool List.list => Tools.toreall"), - [Free ("x_i","bool List.list")]) *) - - -(*.match the actual arguments of a SubProblem with a model-pattern - and create an ori list (in root-pbl created from formalization). - expects ags:pats = 1:1, while copy-named are filtered out of pats; - copy-named pats are appended in order to get them into the model-items.*) -fun match_ags thy (pbt:pat list) ags = -(* val (thy, pbt, ags) = (thy, (#ppc o get_pbt) pI, ags); - val (thy, pbt, ags) = (thy, pats, ags); - *) - let fun flattup (i,(var,bool,str,itm_)) = (i,var,bool,str,itm_); - val pbt' = filter_out is_copy_named pbt; - val cy = filter is_copy_named pbt; - val oris' = matc thy pbt' ags []; - val cy' = map (cpy_nam pbt' oris') cy; - val ors = add_id (oris' @ cy'); - (*appended in order to get ^^^^^ them into the model-items*) - in (map flattup ors):ori list end; -(*vars as above .. -> match_ags thy pbt ags; -val it = - [(1,[1],"#Given",Const ("Descript.equality","bool => Tools.una"), - [Const # $ (# $ #) $ Free (#,#)]), - (2,[1],"#Given",Const ("Descript.solveFor","RealDef.real => Tools.una"), - [Free ("x","RealDef.real")]), - (3,[1],"#Find", - Const ("Descript.solutions","bool List.list => Tools.toreall"), - [Free ("x_i","bool List.list")])] : ori list*) - -(*.report part of the error-msg which is not available in match_args.*) -fun match_ags_msg pI stac ags = - let val s = !show_types - val _ = show_types:= true - val pats = (#ppc o get_pbt) pI - val msg = (dots 70^"\n" - ^"*** problem "^strs2str pI^" has the ...\n" - ^"*** model-pattern "^pats2str pats^"\n" - ^"*** stac '"^term2str stac^"' has the ...\n" - ^"*** arg-list "^terms2str ags^"\n" - ^dashs 70) - val _ = show_types:= s - in writeln msg end; - - -(*get the variables out of a pbl_; FIXME.WN.0311: is_copy_named ...obscure!!!*) -fun vars_of_pbl_ pbl_ = - let fun var_of_pbl_ (gfr,(dsc,t)) = t - in ((map var_of_pbl_) o (filter_out is_copy_named)) pbl_ end; -fun vars_of_pbl_' pbl_ = - let fun var_of_pbl_ (gfr,(dsc,t)) = t:term - in ((map var_of_pbl_)(* o (filter_out is_copy_named)*)) pbl_ end; - -fun overwrite_ppc thy itm ppc = - let - fun repl ppc' (_,_,_,_,itm_) [] = - raise error ("overwrite_ppc: " ^ (itm_2str_ (thy2ctxt thy) itm_) ^ - " not found") - | repl ppc' itm (p::ppc) = - if (#1 itm) = (#1 (p:itm)) then ppc' @ [itm] @ ppc - else repl (ppc' @ [p]) itm ppc - in repl [] itm ppc end; - -(*10.3.00: insert the already compiled itm into model; - ev. filter_out untouched (in FE: (0,...)) item related to insert-item *) -(* val ppc=pbl; - *) -fun insert_ppc thy itm ppc = - let - fun eq_untouched d ((0,_,_,_,itm_):itm) = (d = d_in itm_) - | eq_untouched _ _ = false; - val ppc' = - ( - (*writeln("### insert_ppc: itm= "^(itm2str_ itm));*) - case seek_ppc (#1 itm) ppc of - (* val SOME xxx = seek_ppc (#1 itm) ppc; - *) - SOME _ => (*itm updated in is_notyet_input WN.11.03*) - overwrite_ppc thy itm ppc - | NONE => (ppc @ [itm])); - in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end; - -(*from Isabelle/src/Pure/library.ML, _appends_ a new element*) -fun gen_ins' eq (x, xs) = if gen_mem eq (x, xs) then xs else xs @ [x]; - -fun eq_dsc ((_,_,_,_,itm_):itm, (_,_,_,_,iitm_):itm) = - (d_in itm_) = (d_in iitm_); -(*insert_ppc = insert_ppc' for appl_add', input_icalhd 11.03, - handles superfluous items carelessly*) -fun insert_ppc' itm itms = gen_ins' eq_dsc (itm, itms); -(* val eee = op=; - > gen_ins' eee (4,[1,3,5,7]); -val it = [1, 3, 5, 7, 4] : int list*) - - -(*. output the headline to a ppc .*) -fun header p_ pI mI = - case p_ of Pbl => Problem (if pI = e_pblID then [] else pI) - | Met => Method mI - | pos => raise error ("header called with "^ pos_2str pos); - - - -(* test-printouts --- -val _=writeln("### insert_ppc: (d,ts)="^((Syntax.string_of_term (thy2ctxt thy))(comp_dts thy(d,ts)))); - val _=writeln("### insert_ppc: pts= "^ -(strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) pts); - - - val sel = "#Given"; val Add_Given' ct = m; - - val sel = "#Find"; val Add_Find' (ct,_) = m; - val (p,_) = p; - val (_,_,f,nxt',_,pt')= specify_additem sel (ct,[]) (p,Pbl(*!!!!!!!*)) c pt; --------------- - val sel = "#Given"; val Add_Given' (ct,_) = nxt; val (p,_) = p; - *) -fun specify_additem sel (ct,_) (p,Met) c pt = - let - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; - (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*) - val cpI = if pI = e_pblID then pI' else pI; - val cmI = if mI = e_metID then mI' else mI; - val {ppc,pre,prls,...} = get_met cmI - in case appl_add thy sel oris met ppc ct of - Add itm (*..union old input *) => - let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct; - *) - val met' = insert_ppc thy itm met; - (*val pt' = update_met pt p met';*) - val ((p,Met),_,_,pt') = - generate1 thy (case sel of - "#Given" => Add_Given' (ct, met') - | "#Find" => Add_Find' (ct, met') - | "#Relate"=> Add_Relation'(ct, met')) - Uistate (p,Met) pt - val pre' = check_preconds thy prls pre met' - val pb = foldl and_ (true, map fst pre') - (*val _=writeln("@@@ specify_additem: Met Add before nxt_spec")*) - val (p_,nxt) = - nxt_spec Met pb oris (dI',pI',mI') (pbl,met') - ((#ppc o get_pbt) cpI,ppc) (dI,pI,mI); - in ((p,p_), ((p,p_),Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (Method cmI, itms2itemppc thy met' pre'))), - nxt,Safe,pt') end - | Err msg => - let val pre' = check_preconds thy prls pre met - val pb = foldl and_ (true, map fst pre') - (*val _=writeln("@@@ specify_additem: Met Err before nxt_spec")*) - val (p_,nxt) = - nxt_spec Met pb oris (dI',pI',mI') (pbl,met) - ((#ppc o get_pbt) cpI,(#ppc o get_met) cmI) (dI,pI,mI); - in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end - end -(* val (p,_) = p; - *) -| specify_additem sel (ct,_) (p,_(*Frm, Pbl*)) c pt = - let - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; - val cpI = if pI = e_pblID then pI' else pI; - val cmI = if mI = e_metID then mI' else mI; - val {ppc,where_,prls,...} = get_pbt cpI; - in case appl_add thy sel oris pbl ppc ct of - Add itm (*..union old input *) => - (* val Add itm = appl_add thy sel oris pbl ppc ct; - *) - let - (*val _= writeln("###specify_additem: itm= "^(itm2str_ itm));*) - val pbl' = insert_ppc thy itm pbl - val ((p,Pbl),_,_,pt') = - generate1 thy (case sel of - "#Given" => Add_Given' (ct, pbl') - | "#Find" => Add_Find' (ct, pbl') - | "#Relate"=> Add_Relation'(ct, pbl')) - Uistate (p,Pbl) pt - val pre = check_preconds thy prls where_ pbl' - val pb = foldl and_ (true, map fst pre) - (*val _=writeln("@@@ specify_additem: Pbl Add before nxt_spec")*) - val (p_,nxt) = - nxt_spec Pbl pb oris (dI',pI',mI') (pbl',met) - (ppc,(#ppc o get_met) cmI) (dI,pI,mI); - val ppc = if p_= Pbl then pbl' else met; - in ((p,p_), ((p,p_),Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (header p_ pI cmI, - itms2itemppc thy ppc pre))), nxt,Safe,pt') end - - | Err msg => - let val pre = check_preconds thy prls where_ pbl - val pb = foldl and_ (true, map fst pre) - (*val _=writeln("@@@ specify_additem: Pbl Err before nxt_spec")*) - val (p_,nxt) = - nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met) - (ppc,(#ppc o get_met) cmI) (dI,pI,mI); - in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end - end; -(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt; - val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Met) c pt; - *) - -(* ori -val (msg,itm) = appl_add thy sel oris ppc ct; -val (Cor(d,ts)) = #5 itm; -map (atomty) ts; - -pre -*) - - -(* val Init_Proof' (fmz,(dI',pI',mI')) = m; - specify (Init_Proof' (fmz,(dI',pI',mI'))) e_pos' [] EmptyPtree; - *) -fun specify (Init_Proof' (fmz,(dI',pI',mI'))) (_:pos') (_:cid) (_:ptree)= - let (* either """"""""""""""" all empty or complete *) - val thy = assoc_thy dI'; - val oris = if dI' = e_domID orelse pI' = e_pblID then ([]:ori list) - else prep_ori fmz thy ((#ppc o get_pbt) pI'); - val (pt,c) = cappend_problem e_ptree [] e_istate (fmz,(dI',pI',mI')) - (oris,(dI',pI',mI'),e_term); - val {ppc,prls,where_,...} = get_pbt pI' - (*val pbl = init_pbl ppc; WN.9.03: done in Model/Refine_Problem - val pt = update_pbl pt [] pbl; - val pre = check_preconds thy prls where_ pbl - val pb = foldl and_ (true, map fst pre)*) - val (pbl, pre, pb) = ([], [], false) - in case mI' of - ["no_met"] => - (([],Pbl), (([],Pbl),Uistate), - Form' (PpcKF (0,EdUndef,(length []),Nundef, - (Problem [], itms2itemppc (assoc_thy dI') pbl pre))), - Refine_Tacitly pI', Safe,pt) - | _ => - (([],Pbl), (([],Pbl),Uistate), - Form' (PpcKF (0,EdUndef,(length []),Nundef, - (Problem [], itms2itemppc (assoc_thy dI') pbl pre))), - Model_Problem, - Safe,pt) - end - (*ONLY for STARTING modeling phase*) - | specify (Model_Problem' (_,pbl,met)) (pos as (p,p_)) c pt = - let (* val (Model_Problem' (_,pbl), pos as (p,p_)) = (m, (p,p_)); - *) - val (PblObj{origin=(oris,(dI',pI',mI'),_), spec=(dI,_,_),...}) = - get_obj I pt p - val thy' = if dI = e_domID then dI' else dI - val thy = assoc_thy thy' - val {ppc,prls,where_,...} = get_pbt pI' - val pre = check_preconds thy prls where_ pbl - val pb = foldl and_ (true, map fst pre) - val ((p,_),_,_,pt) = - generate1 thy (Model_Problem'([],pbl,met)) Uistate pos pt - val (_,nxt) = nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met) - (ppc,(#ppc o get_met) mI') (dI',pI',mI'); - in ((p,Pbl), ((p,p_),Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (Problem pI', itms2itemppc (assoc_thy dI') pbl pre))), - nxt, Safe, pt) end - -(*. called only if no_met is specified .*) - | specify (Refine_Tacitly' (pI,pIre,_,_,_)) (pos as (p,_)) c pt = - let (* val Refine_Tacitly' (pI,pIre,_,_,_) = m; - *) - val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, ...}) = - get_obj I pt p; - val {prls,met,ppc,thy,where_,...} = get_pbt pIre - (*val pbl = init_pbl ppc --- Model_Problem recognizes probl=[]*) - (*val pt = update_pbl pt p pbl; - val pt = update_orispec pt p - (string_of_thy thy, pIre, - if length met = 0 then e_metID else hd met);*) - val (domID, metID) = (string_of_thy thy, - if length met = 0 then e_metID else hd met) - val ((p,_),_,_,pt) = - generate1 thy (Refine_Tacitly'(pI,pIre,domID,metID,(*pbl*)[])) - Uistate pos pt - (*val pre = check_preconds thy prls where_ pbl - val pb = foldl and_ (true, map fst pre)*) - val (pbl, pre, pb) = ([], [], false) - in ((p,Pbl), (pos,Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (Problem pIre, itms2itemppc (assoc_thy dI') pbl pre))), - Model_Problem, Safe, pt) end - - | specify (Refine_Problem' (rfd as (pI,_))) pos c pt = - let val (pos,_,_,pt) = generate1 (assoc_thy "Isac.thy") - (Refine_Problem' rfd) Uistate pos pt - in (pos(*p,Pbl*), (pos(*p,Pbl*),Uistate), Problems (RefinedKF rfd), - Model_Problem, Safe, pt) end - -(* val (Specify_Problem' (pI, (ok, (itms, pre)))) = nxt; val (p,_) = p; - val (Specify_Problem' (pI, (ok, (itms, pre)))) = m; val (p,_) = p; - *) - | specify (Specify_Problem' (pI, (ok, (itms, pre)))) (pos as (p,_)) c pt = - let val (PblObj {origin=(oris,(dI',pI',mI'),_), spec=(dI,_,mI), - meth=met, ...}) = get_obj I pt p; - (*val pt = update_pbl pt p itms; - val pt = update_pblID pt p pI;*) - val thy = assoc_thy dI - val ((p,Pbl),_,_,pt)= - generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate pos pt - val dI'' = assoc_thy (if dI=e_domID then dI' else dI); - val mI'' = if mI=e_metID then mI' else mI; - (*val _=writeln("@@@ specify (Specify_Problem) before nxt_spec")*) - val (_,nxt) = nxt_spec Pbl ok oris (dI',pI',mI') (itms, met) - ((#ppc o get_pbt) pI,(#ppc o get_met) mI'') (dI,pI,mI); - in ((p,Pbl), (pos,Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (Problem pI, itms2itemppc dI'' itms pre))), - nxt, Safe, pt) end -(* val Specify_Method' mID = nxt; val (p,_) = p; - val Specify_Method' mID = m; - specify (Specify_Method' mID) (p,p_) c pt; - *) - | specify (Specify_Method' (mID,_,_)) (pos as (p,_)) c pt = - let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI), - meth=met, ...}) = get_obj I pt p; - val {ppc,pre,prls,...} = get_met mID - val thy = assoc_thy dI - val oris = add_field' thy ppc oris; - (*val pt = update_oris pt p oris; 20.3.02: repl. "#undef"*) - val dI'' = if dI=e_domID then dI' else dI; - val pI'' = if pI = e_pblID then pI' else pI; - val met = if met=[] then pbl else met; - val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris; - (*val pt = update_met pt p itms; - val pt = update_metID pt p mID*) - val (pos,_,_,pt)= - generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt - (*val _=writeln("@@@ specify (Specify_Method) before nxt_spec")*) - val (_,nxt) = nxt_spec Met (*ok*)true oris (dI',pI',mI') (pbl, itms) - ((#ppc o get_pbt) pI'',ppc) (dI'',pI'',mID); - in (pos, (pos,Uistate), - Form' (PpcKF (0,EdUndef,(length p),Nundef, - (Method mID, itms2itemppc (assoc_thy dI'') itms pre'))), - nxt, Safe, pt) end -(* val Add_Find' ct = nxt; val sel = "#Find"; - *) - | specify (Add_Given' ct) p c pt = specify_additem "#Given" ct p c pt - | specify (Add_Find' ct) p c pt = specify_additem "#Find" ct p c pt - | specify (Add_Relation' ct) p c pt=specify_additem"#Relate"ct p c pt -(* val Specify_Theory' domID = m; - val (Specify_Theory' domID, (p,p_)) = (m, pos); - *) - | specify (Specify_Theory' domID) (pos as (p,p_)) c pt = - let val p_ = case p_ of Met => Met | _ => Pbl - val thy = assoc_thy domID; - val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, - probl=pbl, spec=(dI,pI,mI),...}) = get_obj I pt p; - val mppc = case p_ of Met => met | _ => pbl; - val cpI = if pI = e_pblID then pI' else pI; - val {prls=per,ppc,where_=pwh,...} = get_pbt cpI - val cmI = if mI = e_metID then mI' else mI; - val {prls=mer,ppc=mpc,pre=mwh,...} = get_met cmI - val pre = - case p_ of - Met => (check_preconds thy mer mwh met) - | _ => (check_preconds thy per pwh pbl) - val pb = foldl and_ (true, map fst pre) - in if domID = dI - then let - (*val _=writeln("@@@ specify (Specify_Theory) THEN before nxt_spec")*) - val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') - (pbl,met) (ppc,mpc) (dI,pI,mI); - in ((p,p_), (pos,Uistate), - Form'(PpcKF (0,EdUndef,(length p), Nundef, - (header p_ pI cmI, itms2itemppc thy mppc pre))), - nxt,Safe,pt) end - else (*FIXME: check ppc wrt. (new!) domID ..? still parsable?*) - let - (*val pt = update_domID pt p domID;11.8.03*) - val ((p,p_),_,_,pt) = generate1 thy (Specify_Theory' domID) - Uistate (p,p_) pt - (*val _=writeln("@@@ specify (Specify_Theory) ELSE before nxt_spec")*) - val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') (pbl,met) - (ppc,mpc) (domID,pI,mI); - in ((p,p_), (pos,Uistate), - Form' (PpcKF (0, EdUndef, (length p),Nundef, - (header p_ pI cmI, itms2itemppc thy mppc pre))), - nxt, Safe,pt) end - end -(* itms2itemppc thy [](*mpc*) pre - *) - | specify m' _ _ _ = - raise error ("specify: not impl. for "^tac_2str m'); - -(* val (sel, Add_Given ct, ptp as (pt,(p,Pbl))) = ("#Given", tac, ptp); - val (sel, Add_Find ct, ptp as (pt,(p,Pbl))) = ("#Find", tac, ptp); - *) -fun nxt_specif_additem sel ct (ptp as (pt,(p,Pbl))) = - let - val (PblObj{meth=met,origin=(oris,(dI',pI',_),_), - probl=pbl,spec=(dI,pI,_),...}) = get_obj I pt p; - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; - val cpI = if pI = e_pblID then pI' else pI; - in case appl_add thy sel oris pbl ((#ppc o get_pbt) cpI) ct of - Add itm (*..union old input *) => -(* val Add itm = appl_add thy sel oris pbl ppc ct; - *) - let - (*val _=writeln("###nxt_specif_additem: itm= "^(itm2str_ itm));*) - val pbl' = insert_ppc thy itm pbl - val (tac,tac_) = - case sel of - "#Given" => (Add_Given ct, Add_Given' (ct, pbl')) - | "#Find" => (Add_Find ct, Add_Find' (ct, pbl')) - | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, pbl')) - val ((p,Pbl),c,_,pt') = - generate1 thy tac_ Uistate (p,Pbl) pt - in ([(tac,tac_,((p,Pbl),Uistate))], c, (pt',(p,Pbl))):calcstate' end - - | Err msg => - (*TODO.WN03 pass error-msgs to the frontend.. - FIXME ..and dont abuse a tactic for that purpose*) - ([(Tac msg, - Tac_ (theory "Pure", msg,msg,msg), - (e_pos', e_istate))], [], ptp) - end - -(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt; - val (_,_,f,nxt',_,pt')= nxt_specif_additem sel ct (p,Met) c pt; - *) - | nxt_specif_additem sel ct (ptp as (pt,(p,Met))) = - let - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_), - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p; - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI; - val cmI = if mI = e_metID then mI' else mI; - in case appl_add thy sel oris met ((#ppc o get_met) cmI) ct of - Add itm (*..union old input *) => - let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct; - *) - val met' = insert_ppc thy itm met; - val (tac,tac_) = - case sel of - "#Given" => (Add_Given ct, Add_Given' (ct, met')) - | "#Find" => (Add_Find ct, Add_Find' (ct, met')) - | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, met')) - val ((p,Met),c,_,pt') = - generate1 thy tac_ Uistate (p,Met) pt - in ([(tac,tac_,((p,Met), Uistate))], c, (pt',(p,Met))) end - - | Err msg => ([(*tacis*)], [], ptp) - (*nxt_me collects tacis until not hide; here just no progress*) - end; - -(* ori -val (msg,itm) = appl_add thy sel oris ppc ct; -val (Cor(d,ts)) = #5 itm; -map (atomty) ts; - -pre -*) -fun ori2Coritm pbt ((i,v,f,d,ts):ori) = - (i,v,true,f, Cor ((d,ts),(((snd o snd o the o (find_first (eq1 d))) pbt) - handle _ => raise error ("ori2Coritm: dsc "^ - term2str d^ - "in ori, but not in pbt") - ,ts))):itm; -fun ori2Coritm (pbt:pat list) ((i,v,f,d,ts):ori) = - ((i,v,true,f, Cor ((d,ts),((snd o snd o the o - (find_first (eq1 d))) pbt,ts))):itm) - handle _ => (*dsc in oris, but not in pbl pat list: keep this dsc*) - ((i,v,true,f, Cor ((d,ts),(d,ts))):itm); - - -(*filter out oris which have same description in itms*) -fun filter_outs oris [] = oris - | filter_outs oris (i::itms) = - let val ors = filter_out ((curry op= ((d_in o #5) (i:itm))) o - (#4:ori -> term)) oris; - in filter_outs ors itms end; - -fun memI a b = member op = a b; -(*filter oris which are in pbt, too*) -fun filter_pbt oris pbt = - let val dscs = map (fst o snd) pbt - in filter ((memI dscs) o (#4: ori -> term)) oris end; - -(*.combine itms from pbl + met and complete them wrt. pbt.*) -(*FIXXXME.WN031205 complete_metitms doesnt handle incorrect itms !*) -local infix mem; -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun complete_metitms (oris:ori list) (pits:itm list) (mits:itm list) met = -(* val met = (#ppc o get_met) ["DiffApp","max_by_calculus"]; - *) - let val vat = max_vt pits; - val itms = pits @ - (filter ((curry (op mem) vat) o (#2:itm -> int list)) mits); - val ors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris; - val os = filter_outs ors itms; - (*WN.12.03?: does _NOT_ add itms from met ?!*) - in itms @ (map (ori2Coritm met) os) end -end; - - - -(*.complete model and guard of a calc-head .*) -local infix mem; -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun complete_mod_ (oris, mpc, ppc, probl) = - let val pits = filter_out ((curry op= false) o (#3: itm -> bool)) probl - val vat = if probl = [] then 1 else max_vt probl - val pors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris - val pors = filter_outs pors pits (*which are in pbl already*) - val pors = (filter_pbt pors ppc) (*which are in pbt, too*) - - val pits = pits @ (map (ori2Coritm ppc) pors) - val mits = complete_metitms oris pits [] mpc - in (pits, mits) end -end; - -fun some_spec ((odI, opI, omI):spec) ((dI, pI, mI):spec) = - (if dI = e_domID then odI else dI, - if pI = e_pblID then opI else pI, - if mI = e_metID then omI else mI):spec; - - -(*.find a next applicable tac (for calcstate) and update ptree - (for ev. finding several more tacs due to hide).*) -(*FIXXXME: unify ... fun nxt_specif = nxt_spec + applicable_in + specify !!*) -(*WN.24.10.03 ~~~~~~~~~~~~~~ -> tac -> tac_ -> -"- as arg*) -(*WN.24.10.03 fun nxt_solv = ...................................??*) -fun nxt_specif (tac as Model_Problem) (pt, pos as (p,p_)) = - let - val (PblObj{origin=(oris,ospec,_),probl,spec,...}) = get_obj I pt p - val (dI,pI,mI) = some_spec ospec spec - val thy = assoc_thy dI - val mpc = (#ppc o get_met) mI (*just for reuse complete_mod_*) - val {cas,ppc,...} = get_pbt pI - val pbl = init_pbl ppc (*fill in descriptions*) - (*--------------if you think, this should be done by the Dialog - in the java front-end, search there for WN060225-modelProblem----*) - val (pbl,met) = case cas of NONE => (pbl,[]) - | _ => complete_mod_ (oris, mpc, ppc, probl) - (*----------------------------------------------------------------*) - val tac_ = Model_Problem' (pI, pbl, met) - val (pos,c,_,pt) = generate1 thy tac_ Uistate pos pt - in ([(tac,tac_, (pos, Uistate))], c, (pt,pos)):calcstate' end - -(* val Add_Find ct = tac; - *) - | nxt_specif (Add_Given ct) ptp = nxt_specif_additem "#Given" ct ptp - | nxt_specif (Add_Find ct) ptp = nxt_specif_additem "#Find" ct ptp - | nxt_specif (Add_Relation ct) ptp = nxt_specif_additem"#Relate" ct ptp - -(*. called only if no_met is specified .*) - | nxt_specif (Refine_Tacitly pI) (ptp as (pt, pos as (p,_))) = - let val (PblObj {origin = (oris, (dI,_,_),_), ...}) = get_obj I pt p - val opt = refine_ori oris pI - in case opt of - SOME pI' => - let val {met,ppc,...} = get_pbt pI' - val pbl = init_pbl ppc - (*val pt = update_pbl pt p pbl ..done by Model_Problem*) - val mI = if length met = 0 then e_metID else hd met - val thy = assoc_thy dI - val (pos,c,_,pt) = - generate1 thy (Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[])) - Uistate pos pt - in ([(Refine_Tacitly pI, Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]), - (pos, Uistate))], c, (pt,pos)) end - | NONE => ([], [], ptp) - end - - | nxt_specif (Refine_Problem pI) (ptp as (pt, pos as (p,_))) = - let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_), - probl, ...}) = get_obj I pt p - val thy = if dI' = e_domID then dI else dI' - in case refine_pbl (assoc_thy thy) pI probl of - NONE => ([], [], ptp) - | SOME (rfd as (pI',_)) => - let val (pos,c,_,pt) = - generate1 (assoc_thy thy) - (Refine_Problem' rfd) Uistate pos pt - in ([(Refine_Problem pI, Refine_Problem' rfd, - (pos, Uistate))], c, (pt,pos)) end - end - - | nxt_specif (Specify_Problem pI) (pt, pos as (p,_)) = - let val (PblObj {origin=(oris,(dI,_,_),_),spec=(dI',pI',_), - probl, ...}) = get_obj I pt p; - val thy = assoc_thy (if dI' = e_domID then dI else dI'); - val {ppc,where_,prls,...} = get_pbt pI - val pbl as (_,(itms,_)) = - if pI'=e_pblID andalso pI=e_pblID - then (false, (init_pbl ppc, [])) - else match_itms_oris thy probl (ppc,where_,prls) oris(*FIXXXXXME?*) - (*FIXXXME~~~~~~~~~~~~~~~: take pbl and compare with new pI WN.8.03*) - val ((p,Pbl),c,_,pt)= - generate1 thy (Specify_Problem' (pI, pbl)) Uistate pos pt - in ([(Specify_Problem pI, Specify_Problem' (pI, pbl), - (pos,Uistate))], c, (pt,pos)) end - - (*transfers oris (not required in pbl) to met-model for script-env - FIXME.WN.8.03: application of several mIDs to SAME model?*) - | nxt_specif (Specify_Method mID) (ptp as (pt, pos as (p,_))) = - let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI), - meth=met, ...}) = get_obj I pt p; - val {ppc,pre,prls,...} = get_met mID - val thy = assoc_thy dI - val oris = add_field' thy ppc oris; - val dI'' = if dI=e_domID then dI' else dI; - val pI'' = if pI = e_pblID then pI' else pI; - val met = if met=[] then pbl else met;(*WN0602 what if more itms in met?*) - val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris; - val (pos,c,_,pt)= - generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt - in ([(Specify_Method mID, Specify_Method' (mID, oris, itms), - (pos,Uistate))], c, (pt,pos)) end - - | nxt_specif (Specify_Theory dI) (pt, pos as (p,Pbl)) = - let val (dI',_,_) = get_obj g_spec pt p - val (pos,c,_,pt) = - generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI) - Uistate pos pt - in (*FIXXXME: check if pbl can still be parsed*) - ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c, - (pt, pos)) end - - | nxt_specif (Specify_Theory dI) (pt, pos as (p,Met)) = - let val (dI',_,_) = get_obj g_spec pt p - val (pos,c,_,pt) = - generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI) - Uistate pos pt - in (*FIXXXME: check if met can still be parsed*) - ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c, - (pt, pos)) end - - | nxt_specif m' _ = - raise error ("nxt_specif: not impl. for "^tac2str m'); - -(*.get the values from oris; handle the term list w.r.t. penv.*) - -local infix mem; -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun vals_of_oris oris = - ((map (mkval' o (#5:ori -> term list))) o - (filter ((curry (op mem) 1) o (#2:ori -> int list)))) oris -end; - - - -(*.create a calc-tree with oris via an cas.refined pbl.*) -fun nxt_specify_init_calc (([],(dI,pI,mI)): fmz) = -(* val ([],(dI,pI,mI)) = (fmz, sp); - *) - if pI <> [] then (*comes from pbl-browser*) - let val {cas,met,ppc,thy,...} = get_pbt pI - val dI = if dI = "" then theory2theory' thy else dI - val thy = assoc_thy dI - val mI = if mI = [] then hd met else mI - val hdl = case cas of NONE => pblterm dI pI | SOME t => t - val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI)) - ([], (dI,pI,mI), hdl) - val pt = update_spec pt [] (dI,pI,mI) - val pits = init_pbl' ppc - val pt = update_pbl pt [] pits - in ((pt,([],Pbl)), []): calcstate end - else if mI <> [] then (*comes from met-browser*) - let val {ppc,...} = get_met mI - val dI = if dI = "" then "Isac.thy" else dI - val thy = assoc_thy dI - val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI)) - ([], (dI,pI,mI), e_term(*FIXME met*)) - val pt = update_spec pt [] (dI,pI,mI) - val mits = init_pbl' ppc - val pt = update_met pt [] mits - in ((pt,([],Met)), []) end - else (*completely new example*) - let val (pt,_) = cappend_problem e_ptree [] e_istate ([], e_spec) - ([], e_spec, e_term) - in ((pt,([],Pbl)), []) end -(* val (fmz, (dI,pI,mI)) = (fmz, sp); - *) - | nxt_specify_init_calc (fmz:fmz_,(dI,pI,mI):spec) = - let (* either """"""""""""""" all empty or complete *) - val thy = assoc_thy dI - val (pI, pors, mI) = - if mI = ["no_met"] - then let val pors = prep_ori fmz thy ((#ppc o get_pbt) pI) - val pI' = refine_ori' pors pI; - in (pI', pors (*refinement over models with diff.prec only*), - (hd o #met o get_pbt) pI') end - else (pI, prep_ori fmz thy ((#ppc o get_pbt) pI), mI) - val {cas,ppc,thy=thy',...} = get_pbt pI (*take dI from _refined_ pbl*) - val dI = theory2theory' (maxthy thy thy'); - val hdl = case cas of - NONE => pblterm dI pI - | SOME t => subst_atomic ((vars_of_pbl_' ppc) - ~~~ vals_of_oris pors) t - val (pt,_) = cappend_problem e_ptree [] e_istate (fmz,(dI,pI,mI)) - (pors,(dI,pI,mI),hdl) - (*val pbl = init_pbl ppc WN.9.03: done by Model/Refine_Problem - val pt = update_pbl pt [] pbl*) - in ((pt,([],Pbl)), fst3 (nxt_specif Model_Problem (pt, ([],Pbl)))) - end; - - - -(*18.12.99*) -fun get_spec_form (m:tac_) ((p,p_):pos') (pt:ptree) = -(* case appl_spec p pt m of /// 19.1.00 - Notappl e => Error' (Error_ e) - | Appl => -*) let val (_,_,f,_,_,_) = specify m (p,p_) [] pt - in f end; - - -(*fun tag_form thy (formal, given) = cterm_of thy - (((head_of o term_of) given) $ (term_of formal)); WN100819*) -fun tag_form thy (formal, given) = - (let val gf = (head_of given) $ formal; - val _ = cterm_of thy gf - in gf end) - handle _ => raise error ("calchead.tag_form: " ^ - Syntax.string_of_term (thy2ctxt thy) given ^ - " .. " ^ - Syntax.string_of_term (thy2ctxt thy) formal ^ - " ..types do not match"); -(* val formal = (the o (parse thy)) "[R::real]"; -> val given = (the o (parse thy)) "fixed_values (cs::real list)"; -> tag_form thy (formal, given); -val it = "fixed_values [R]" : cterm -*) -fun chktyp thy (n, fs, gs) = - ((writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) fs; - (writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) gs; - tag_form thy (nth n fs, nth n gs)); - -fun chktyps thy (fs, gs) = map (tag_form thy) (fs ~~ gs); - -(* ##################################################### - find the failing item: -> val n = 2; -> val tag__form = chktyp (n,formals,givens); -> (type_of o term_of o (nth n)) formals; -> (type_of o term_of o (nth n)) givens; -> atomty ((term_of o (nth n)) formals); -> atomty ((term_of o (nth n)) givens); -> atomty (term_of tag__form); -> use_thy"isa-98-1-HOL-plus/knowl-base/DiffAppl"; - ##################################################### *) - -(* ##################################################### - testdata setup -val origin = ["sqrt(9+4*x)=sqrt x + sqrt(5+x)","x::rat","(+0)"]; -val formals = map (the o (parse thy)) origin; - -val given = ["equation (lhs=rhs)", - "bound_variable bdv", (* TODO type *) - "error_bound apx"]; -val where_ = ["e is_root_equation_in bdv", - "bdv is_var", - "apx is_const_expr"]; -val find = ["L::rat set"]; -val with_ = ["L = {bdv. || ((%x. lhs) bdv) - ((%x. rhs) bdv) || < apx}"]; -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_); -val givens = map (the o (parse thy)) given; - -val tag__forms = chktyps (formals, givens); -map ((atomty) o term_of) tag__forms; - ##################################################### *) - - -(* check pbltypes, announces one failure a time *) -(*fun chk_vars ctppc = - let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} = - appc flat (mappc (vars o term_of) ctppc) - in if (wh\\gi) <> [] then ("wh\\gi",wh\\gi) - else if (re\\(gi union fi)) <> [] - then ("re\\(gi union fi)",re\\(gi union fi)) - else ("ok",[]) end;*) -fun chk_vars ctppc = - let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} = - appc flat (mappc vars ctppc) - val chked = subtract op = gi wh - in if chked <> [] then ("wh\\gi", chked) - else let val chked = subtract op = (union op = gi fi) re - in if chked <> [] - then ("re\\(gi union fi)", chked) - else ("ok", []) - end - end; - -(* check a new pbltype: variables (Free) unbound by given, find*) -fun unbound_ppc ctppc = - let val {Given=gi,Find=fi,Relate=re,...} = - appc flat (mappc vars ctppc) - in distinct (*re\\(gi union fi)*) - (subtract op = (union op = gi fi) re) end; -(* -> val org = {Given=["[R=(R::real)]"],Where=[], - Find=["[A::real]"],With=[], - Relate=["[A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"] - }:string ppc; -> val ctppc = mappc (the o (parse thy)) org; -> unbound_ppc ctppc; -val it = [("a","RealDef.real"),("b","RealDef.real")] : (string * typ) list -*) - - -(* f, a binary operator, is nested rightassociative *) -fun foldr1 f xs = - let - fun fld f (x::[]) = x - | fld f (x::x'::[]) = f (x',x) - | fld f (x::x'::xs) = f (fld f (x'::xs),x); - in ((fld f) o rev) xs end; -(* -> val (SOME ct) = parse thy "[a=b,c=d,e=f]"; -> val ces = map (cterm_of thy) (isalist2list (term_of ct)); -> val conj = foldr1 HOLogic.mk_conj (isalist2list (term_of ct)); -> cterm_of thy conj; -val it = "(a = b & c = d) & e = f" : cterm -*) - -(* f, a binary operator, is nested leftassociative *) -fun foldl1 f (x::[]) = x - | foldl1 f (x::x'::[]) = f (x,x') - | foldl1 f (x::x'::xs) = f (x,foldl1 f (x'::xs)); -(* -> val (SOME ct) = parse thy "[a=b,c=d,e=f,g=h]"; -> val ces = map (cterm_of thy) (isalist2list (term_of ct)); -> val conj = foldl1 HOLogic.mk_conj (isalist2list (term_of ct)); -> cterm_of thy conj; -val it = "a = b & c = d & e = f & g = h" : cterm -*) - - -(* called only once, if a Subproblem has been located in the script*) -fun nxt_model_pbl (Subproblem'((_,pblID,metID),_,_,_,_)) ptp = -(* val (Subproblem'((_,pblID,metID),_,_,_,_),ptp) = (m', (pt,(p,p_))); - *) - (case metID of - ["no_met"] => - (snd3 o hd o fst3) (nxt_specif (Refine_Tacitly pblID) ptp) - | _ => (snd3 o hd o fst3) (nxt_specif Model_Problem ptp)) - (*all stored in tac_ itms ^^^^^^^^^^*) - | nxt_model_pbl tac_ _ = - raise error ("nxt_model_pbl: called by tac= "^tac_2str tac_); -(* run subp_rooteq.sml '' - until nxt=("Subproblem",Subproblem ("SqRoot.thy",["univariate","equation"])) -> val (_, (Subproblem'((_,pblID,metID),_,_,_,_),_,_,_,_,_)) = - (last_elem o drop_last) ets''; -> val mst = (last_elem o drop_last) ets''; -> nxt_model_pbl mst; -val it = Refine_Tacitly ["univariate","equation"] : tac -*) - -(*fun eq1 d (_,(d',_)) = (d = d'); ---modspec.sml*) -fun eq4 v (_,vts,_,_,_) = member op = vts v; -fun eq5 (_,_,_,_,itm_) (_,_,_,d,_) = d_in itm_ = d; - - - -(* - writeln (oris2str pors); - - writeln (itms2str_ thy pits); - writeln (itms2str_ thy mits); - *) - - -(*.complete _NON_empty calc-head for autocalc (sub-)pbl from oris - + met from fmz; assumes pos on PblObj, meth = [].*) -fun complete_mod (pt, pos as (p, p_):pos') = -(* val (pt, (p, _)) = (pt, p); - val (pt, (p, _)) = (pt, pos); - *) - let val _= if p_ <> Pbl - then writeln("###complete_mod: only impl.for Pbl, called with "^ - pos'2str pos) else () - val (PblObj{origin=(oris, ospec, hdl), probl, spec,...}) = - get_obj I pt p - val (dI,pI,mI) = some_spec ospec spec - val mpc = (#ppc o get_met) mI - val ppc = (#ppc o get_pbt) pI - val (pits, mits) = complete_mod_ (oris, mpc, ppc, probl) - val pt = update_pblppc pt p pits - val pt = update_metppc pt p mits - in (pt, (p,Met):pos') end -; -(*| complete_mod (pt, pos as (p, Met):pos') = - raise error ("###complete_mod: only impl.for Pbl, called with "^ - pos'2str pos);*) - -(*.complete _EMPTY_ calc-head for autocalc (sub-)pbl from oris(+met from fmz); - oris and spec (incl. pbl-refinement) given from init_calc or SubProblem .*) -fun all_modspec (pt, (p,_):pos') = -(* val (pt, (p,_)) = ptp; - *) - let val (PblObj{fmz=(fmz_,_), origin=(pors, spec as (dI,pI,mI), hdl), - ...}) = get_obj I pt p; - val thy = assoc_thy dI; - val {ppc,...} = get_met mI; - val mors = prep_ori fmz_ thy ppc; - val pt = update_pblppc pt p (map (ori2Coritm ppc) pors); - val pt = update_metppc pt p (map (ori2Coritm ppc) mors); - val pt = update_spec pt p (dI,pI,mI); - in (pt, (p,Met): pos') end; - -(*WN.12.03: use in nxt_spec, too ? what about variants ???*) -fun is_complete_mod_ ([]: itm list) = false - | is_complete_mod_ itms = - foldl and_ (true, (map #3 itms)); -fun is_complete_mod (pt, pos as (p, Pbl): pos') = - if (is_pblobj o (get_obj I pt)) p - then (is_complete_mod_ o (get_obj g_pbl pt)) p - else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos) - | is_complete_mod (pt, pos as (p, Met)) = - if (is_pblobj o (get_obj I pt)) p - then (is_complete_mod_ o (get_obj g_met pt)) p - else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos) - | is_complete_mod (_, pos) = - raise error ("is_complete_mod called by "^pos'2str pos^ - " (should be Pbl or Met)"); - -(*.have (thy, pbl, met) _all_ been specified explicitly ?.*) -fun is_complete_spec (pt, pos as (p,_): pos') = - if (not o is_pblobj o (get_obj I pt)) p - then raise error ("is_complete_spec: called by PrfObj at "^pos'2str pos) - else let val (dI,pI,mI) = get_obj g_spec pt p - in dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID end; -(*.complete empty items in specification from origin (pbl, met ev.refined); - assumes 'is_complete_mod'.*) -fun complete_spec (pt, pos as (p,_): pos') = - let val PblObj {origin = (_,ospec,_), spec,...} = get_obj I pt p - val pt = update_spec pt p (some_spec ospec spec) - in (pt, pos) end; - -fun is_complete_modspec ptp = - is_complete_mod ptp andalso is_complete_spec ptp; - - - - -fun pt_model (PblObj {meth,spec,origin=(_,spec',hdl),...}) Met = -(* val ((PblObj {meth,spec,origin=(_,spec',hdl),...}), Met) = (ppobj, p_); - *) - let val (_,_,metID) = get_somespec' spec spec' - val pre = - if metID = e_metID then [] - else let val {prls,pre=where_,...} = get_met metID - val pre = check_preconds' prls where_ meth 0 - in pre end - val allcorrect = is_complete_mod_ meth - andalso foldl and_ (true, (map #1 pre)) - in ModSpec (allcorrect, Met, hdl, meth, pre, spec) end - | pt_model (PblObj {probl,spec,origin=(_,spec',hdl),...}) _(*Frm,Pbl*) = -(* val ((PblObj {probl,spec,origin=(_,spec',hdl),...}),_) = (ppobj, p_); - *) - let val (_,pI,_) = get_somespec' spec spec' - val pre = - if pI = e_pblID then [] - else let val {prls,where_,cas,...} = get_pbt pI - val pre = check_preconds' prls where_ probl 0 - in pre end - val allcorrect = is_complete_mod_ probl - andalso foldl and_ (true, (map #1 pre)) - in ModSpec (allcorrect, Pbl, hdl, probl, pre, spec) end; - - -fun pt_form (PrfObj {form,...}) = Form form - | pt_form (PblObj {probl,spec,origin=(_,spec',_),...}) = - let val (dI, pI, _) = get_somespec' spec spec' - val {cas,...} = get_pbt pI - in case cas of - NONE => Form (pblterm dI pI) - | SOME t => Form (subst_atomic (mk_env probl) t) - end; -(*vvv takes the tac _generating_ the formula=result, asm ok.... -fun pt_result (PrfObj {result=(t,asm), tac,...}) = - (Form t, - if null asm then NONE else SOME asm, - SOME tac) - | pt_result (PblObj {result=(t,asm), origin = (_,ospec,_), spec,...}) = - let val (_,_,metID) = some_spec ospec spec - in (Form t, - if null asm then NONE else SOME asm, - if metID = e_metID then NONE else SOME (Apply_Method metID)) end; --------------------------------------------------------------------------*) - - -(*.pt_extract returns - # the formula at pos - # the tactic applied to this formula - # the list of assumptions generated at this formula - (by application of another tac to the preceding formula !) - pos is assumed to come from the frontend, ie. generated by moveDown.*) -(*cannot be in ctree.sml, because ModSpec has to be calculated*) -fun pt_extract (pt,([],Res)) = -(* val (pt,([],Res)) = ptp; - *) - let val (f, asm) = get_obj g_result pt [] - in (Form f, NONE, asm) end -(* val p = [3,2]; - *) - | pt_extract (pt,(p,Res)) = -(* val (pt,(p,Res)) = ptp; - *) - let val (f, asm) = get_obj g_result pt p - val tac = if last_onlev pt p - then if is_pblobj' pt (lev_up p) - then let val (PblObj{spec=(_,pI,_),...}) = - get_obj I pt (lev_up p) - in if pI = e_pblID then NONE - else SOME (Check_Postcond pI) end - else SOME End_Trans (*WN0502 TODO for other branches*) - else let val p' = lev_on p - in if is_pblobj' pt p' - then let val (PblObj{origin = (_,(dI,pI,_),_),...}) = - get_obj I pt p' - in SOME (Subproblem (dI, pI)) end - else if f = get_obj g_form pt p' - then SOME (get_obj g_tac pt p') - (*because this Frm ~~~is not on worksheet*) - else SOME (Take (term2str (get_obj g_form pt p'))) - end - in (Form f, tac, asm) end - - | pt_extract (pt, pos as (p,p_(*Frm,Pbl*))) = -(* val (pt, pos as (p,p_(*Frm,Pbl*))) = ptp; - val (pt, pos as (p,p_(*Frm,Pbl*))) = (pt, p); - *) - let val ppobj = get_obj I pt p - val f = if is_pblobj ppobj then pt_model ppobj p_ - else get_obj pt_form pt p - val tac = g_tac ppobj - in (f, SOME tac, []) end; - - -(**. get the formula from a ctree-node: - take form+res from PblObj and 1.PrfObj and (PrfObj after PblObj) - take res from all other PrfObj's .**) -(*designed for interSteps, outcommented 04 in favour of calcChangedEvent*) -fun formres p (Nd (PblObj {origin = (_,_, h), result = (r, _),...}, _)) = - [("headline", (p, Frm), h), - ("stepform", (p, Res), r)] - | formres p (Nd (PrfObj {form, result = (r, _),...}, _)) = - [("stepform", (p, Frm), form), - ("stepform", (p, Res), r)]; - -fun form p (Nd (PrfObj {result = (r, _),...}, _)) = - [("stepform", (p, Res), r)] - -(*assumes to take whole level, in particular hd -- for use in interSteps*) -fun get_formress fs p [] = flat fs - | get_formress fs p (nd::nds) = - (* start with 'form+res' and continue with trying 'res' only*) - get_forms (fs @ [formres p nd]) (lev_on p) nds -and get_forms fs p [] = flat fs - | get_forms fs p (nd::nds) = - if is_pblnd nd - (* start again with 'form+res' ///ugly repeat with Check_elementwise - then get_formress (fs @ [formres p nd]) (lev_on p) nds *) - then get_forms (fs @ [formres p nd]) (lev_on p) nds - (* continue with trying 'res' only*) - else get_forms (fs @ [form p nd]) (lev_on p) nds; - -(**.get an 'interval' 'from' 'to' of formulae from a ptree.**) -(*WN050219 made robust against _'to' below or after Complete nodes - by handling exn caused by move_dn*) -(*WN0401 this functionality belongs to ctree.sml, -but fetching a calc_head requires calculations defined in modspec.sml -transfer to ME/me.sml !!! -WN051224 ^^^ doesnt hold any longer, since only the headline of a calc_head -is returned !!!!!!!!!!!!! -*) -fun eq_pos' (p1,Frm) (p2,Frm) = p1 = p2 - | eq_pos' (p1,Res) (p2,Res) = p1 = p2 - | eq_pos' (p1,Pbl) (p2,p2_) = p1 = p2 andalso (case p2_ of - Pbl => true - | Met => true - | _ => false) - | eq_pos' (p1,Met) (p2,p2_) = p1 = p2 andalso (case p2_ of - Pbl => true - | Met => true - | _ => false) - | eq_pos' _ _ = false; - -(*.get an 'interval' from the ctree; 'interval' is w.r.t. the - total ordering Position#compareTo(Position p) in the java-code -val get_interval = fn - : pos' -> : from is "move_up 1st-element" to return - pos' -> : to the last element to be returned; from < to - int -> : level: 0 gets the flattest sub-tree possible - >999 gets the deepest sub-tree possible - ptree -> : - (pos' * : of the formula - Term.term) : the formula - list -.*) -fun get_interval from to level pt = -(* val (from,level) = (f,lev); - val (from, to, level) = (([3, 2, 1], Res), ([],Res), 9999); - *) - let fun get_inter c (from:pos') (to:pos') lev pt = -(* val (c, from, to, lev) = ([], from, to, level); - ------for recursion....... - val (c, from:pos', to:pos') = (c @ [(from, f)], move_dn [] pt from, to); - *) - if eq_pos' from to orelse from = ([],Res) - (*orelse ... avoids Exception- PTREE "end of calculation" raised, - if 'to' has values NOT generated by move_dn, see systest/me.sml - TODO.WN0501: introduce an order on pos' and check "from > to".. - ...there is an order in Java! - WN051224 the hack got worse with returning term instead ptform*) - then let val (f,_,_) = pt_extract (pt, from) - in case f of - ModSpec (_,_,headline,_,_,_) => c @ [(from, headline)] - | Form t => c @ [(from, t)] - end - else - if lev < lev_of from - then (get_inter c (move_dn [] pt from) to lev pt) - handle (PTREE _(*from move_dn too far*)) => c - else let val (f,_,_) = pt_extract (pt, from) - val term = case f of - ModSpec (_,_,headline,_,_,_)=> headline - | Form t => t - in (get_inter (c @ [(from, term)]) - (move_dn [] pt from) to lev pt) - handle (PTREE _(*from move_dn too far*)) - => c @ [(from, term)] end - in get_inter [] from to level pt end; - -(*for tests*) -fun posform2str (pos:pos', form) = - "("^ pos'2str pos ^", "^ - (case form of - Form f => term2str f - | ModSpec c => term2str (#3 c(*the headline*))) - ^")"; -fun posforms2str pfs = (strs2str' o (map (curry op ^ "\n")) o - (map posform2str)) pfs; -fun posterm2str (pos:pos', t) = - "("^ pos'2str pos ^", "^term2str t^")"; -fun posterms2str pfs = (strs2str' o (map (curry op ^ "\n")) o - (map posterm2str)) pfs; - - -(*WN050225 omits the last step, if pt is incomplete*) -fun show_pt pt = - writeln (posterms2str (get_interval ([],Frm) ([],Res) 99999 pt)); - -(*.get a calchead from a PblObj-node in the ctree; - preconditions must be calculated.*) -fun get_ocalhd (pt, pos' as (p,Pbl):pos') = - let val PblObj {origin = (oris, ospec, hdf'), spec, probl,...} = - get_obj I pt p - val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec)) - val pre = check_preconds (assoc_thy"Isac.thy") prls where_ probl - in (ocalhd_complete probl pre spec, Pbl, hdf', probl, pre, spec):ocalhd end -| get_ocalhd (pt, pos' as (p,Met):pos') = - let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'), - spec, meth,...} = - get_obj I pt p - val {prls,pre,...} = get_met (#3 (some_spec ospec spec)) - val pre = check_preconds (assoc_thy"Isac.thy") prls pre meth - in (ocalhd_complete meth pre spec, Met, hdf', meth, pre, spec):ocalhd end; - -(*.at the activeFormula set the Model, the Guard and the Specification - to empty and return a CalcHead; - the 'origin' remains (for reconstructing all that).*) -fun reset_calchead (pt, pos' as (p,_):pos') = - let val PblObj {origin = (_, _, hdf'),...} = get_obj I pt p - val pt = update_pbl pt p [] - val pt = update_met pt p [] - val pt = update_spec pt p e_spec - in (pt, (p,Pbl):pos') end; - -(*---------------------------------------------------------------------*) -end - -open CalcHead; -(*---------------------------------------------------------------------*) - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/ctree.sml --- a/src/Tools/isac/ME/ctree.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2154 +0,0 @@ -(* use"../ME/ctree.sml"; - use"ME/ctree.sml"; - use"ctree.sml"; - W.N.26.10.99 - -writeln (pr_ptree pr_short pt); - -val Nd ( _, ns) = pt; - -*) - -(*structure Ptree (**): PTREE (**) = ###### outcommented ######*) -signature PTREE = -sig - type ptree - type envp - val e_ptree : ptree - exception PTREE of string - type branch - type ostate - type cellID - type cid - type posel - type pos - type pos' - type loc - type domID - type pblID - type metID - type spec - type 'a ppc - type con - type subs - type subst - type env - type ets - val ets2str : ets -> string - type item - type tac - type tac_ - val tac_2str : tac_ -> string - type safe - val safe2str : safe -> string - - type meth - val cappend_atomic : ptree -> pos -> loc -> cterm' -> tac - -> cterm' -> ostate -> cid -> ptree * posel list * cid - val cappend_form : ptree - -> pos -> loc -> cterm' -> cid -> ptree * pos * cid - val cappend_parent : ptree -> pos -> loc -> cterm' -> tac - -> branch -> cid -> ptree * int list * cid - val cappend_problem : ptree -> posel list(*FIXME*) -> loc - -> cterm' list * spec -> cid -> ptree * int list * cellID list - val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos - - type ppobj - val g_branch : ppobj -> branch - val g_cell : ppobj -> cid - val g_args : ppobj -> (int * (term list)) list (*args of scr*) - val g_form : ppobj -> cterm' - val g_loc : ppobj -> loc - val g_met : ppobj -> meth - val g_domID : ppobj -> domID - val g_metID : ppobj -> metID - val g_model : ppobj -> cterm' ppc - val g_tac : ppobj -> tac - val g_origin : ppobj -> cterm' list * spec - val g_ostate : ppobj -> ostate - val g_pbl : ppobj -> pblID * item ppc - val g_result : ppobj -> cterm' - val g_spec : ppobj -> spec -(* val get_all : (ppobj -> 'a) -> ptree -> 'a list - val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *) - val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a - val gpt_cell : ptree -> cid - val par_pblobj : ptree -> pos -> pos - val pre_pos : pos -> pos - val lev_dn : int list -> int list - val lev_on : pos -> posel list - val lev_pred : pos -> pos - val lev_up : pos -> pos -(* val pr_cell : pos -> ppobj -> string - val pr_pos : int list -> string *) - val pr_ptree : (pos -> ppobj -> string) -> ptree -> string - val pr_short : pos -> ppobj -> string -(* val repl : 'a list -> int -> 'a -> 'a list - val repl_app : 'a list -> int -> 'a -> 'a list - val repl_branch : branch -> ppobj -> ppobj - val repl_domID : domID -> ppobj -> ppobj - val repl_form : cterm' -> ppobj -> ppobj - val repl_met : item ppc -> ppobj -> ppobj - val repl_metID : metID -> ppobj -> ppobj - val repl_model : cterm' list -> ppobj -> ppobj - val repl_tac : tac -> ppobj -> ppobj - val repl_pbl : item ppc -> ppobj -> ppobj - val repl_pblID : pblID -> ppobj -> ppobj - val repl_result : cterm' -> ostate -> ppobj -> ppobj - val repl_spec : spec -> ppobj -> ppobj - val repl_subs : (string * string) list -> ppobj -> ppobj *) - val rootthy : ptree -> domID -(* val test_trans : ppobj -> bool - val uni__asm : (string * pos) list -> ppobj -> ppobj - val uni__cid : cellID list -> ppobj -> ppobj *) - val union_asm : ptree -> pos -> (string * pos) list -> ptree - val union_cid : ptree -> pos -> cellID list -> ptree - val update_branch : ptree -> pos -> branch -> ptree - val update_domID : ptree -> pos -> domID -> ptree - val update_met : ptree -> pos -> meth -> ptree - val update_metppc : ptree -> pos -> item ppc -> ptree - val update_metID : ptree -> pos -> metID -> ptree - val update_tac : ptree -> pos -> tac -> ptree - val update_pbl : ptree -> pos -> pblID * item ppc -> ptree - val update_pblppc : ptree -> pos -> item ppc -> ptree - val update_pblID : ptree -> pos -> pblID -> ptree - val update_spec : ptree -> pos -> spec -> ptree - val update_subs : ptree -> pos -> (string * string) list -> ptree - - val rep_pblobj : ppobj - -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc, - origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc, - result:cterm', spec:spec} - val rep_prfobj : ppobj - -> {branch:branch, cell:cid, form:cterm', loc:loc, tac:tac, - ostate:ostate, result:cterm'} -end - -(* -------------- -structure Ptree (**): PTREE (**) = -struct - -------------- *) - -type env = (term * term) list; - - -datatype branch = - NoBranch | AndB | OrB - | TransitiveB (* FIXXXME.8.03: set branch from met in Apply_Method - FIXXXME.0402: -"- in Begin_Trans'*) - | SequenceB | IntersectB | CollectB | MapB; -fun branch2str NoBranch = "NoBranch" - | branch2str AndB = "AndB" - | branch2str OrB = "OrB" - | branch2str TransitiveB = "TransitiveB" - | branch2str SequenceB = "SequenceB" - | branch2str IntersectB = "IntersectB" - | branch2str CollectB = "CollectB" - | branch2str MapB = "MapB"; - -datatype ostate = - Incomplete | Complete | Inconsistent(*WN041020 latter unused*); -fun ostate2str Incomplete = "Incomplete" - | ostate2str Complete = "Complete" - | ostate2str Inconsistent = "Inconsistent"; - -type cellID = int; -type cid = cellID list; - -type posel = int; (* roundabout for (some of) nice signatures *) -type pos = posel list; -val pos2str = ints2str'; -datatype pos_ = - Pbl (*PblObj-position: problem-type*) - | Met (*PblObj-position: method*) - | Frm (*PblObj-position: -> Pbl in ME (not by moveDown !) - | PrfObj-position: formula*) - | Res (*PblObj | PrfObj-position: result*) - | Und; (*undefined*) -fun pos_2str Pbl = "Pbl" - | pos_2str Met = "Met" - | pos_2str Frm = "Frm" - | pos_2str Res = "Res" - | pos_2str Und = "Und"; - -type pos' = pos * pos_; -(*WN.12.03 remembering interator (pos * pos_) for ptree - pos : lev_on, lev_dn, lev_up, - lev_onFrm, lev_dnRes (..see solve Apply_Method !) - pos_: -# generate1 sets pos_ if possible ...?WN0502?NOT... -# generate1 does NOT set pos, because certain nodes can be lev_on OR lev_dn - exceptions: Begin/End_Trans -# thus generate(1) called in -.# assy, locate_gen -.# nxt_solv (tac_ -cases); general case: - val pos' = case pos' of (p,Res) => (lev_on p',Res) | _ => pos' -# WN050220, S(604): - generate1...(Rewrite(f,..,res))..(pos, pos_) - cappend_atomic.................pos ////// gets f+res always!!! - cut_tree....................pos, pos_ -*) -fun pos'2str (p,p_) = pair2str (ints2str' p, pos_2str p_); -fun pos's2str ps = (strs2str' o (map pos'2str)) ps; -val e_pos' = ([],Und):pos'; - -fun res2str (t, ts) = pair2str (term2str t, terms2str ts); -fun asm2str (t, p:pos) = pair2str (term2str t, ints2str' p); -fun asms2str asms = (strs2str' o (map asm2str)) asms; - - - -(*26.4.02: never used after introduction of scripts !!! -type loc = loc_ * (* + interpreter-state *) - (loc_ * rls') (* -"- for script of the ruleset*) - option; -val e_loc = ([],NONE):loc; -val ee_loc = (e_loc,e_loc);*) - - -datatype safe = Sundef | Safe | Unsafe | Helpless; -fun safe2str Sundef = "Sundef" - | safe2str Safe = "Safe" - | safe2str Unsafe = "Unsafe" - | safe2str Helpless = "Helpless"; - -type subs = cterm' list; (*16.11.00 for FE-KE*) -val e_subs = ["(bdv, x)"]; - -(*._sub_stitution as strings of _e_qualities.*) -type sube = cterm' list; -val e_sube = []:cterm' list; -fun sube2str s = strs2str s; - -(*._sub_stitution as _t_erms of _e_qualities.*) -type subte = term list; -val e_subte = []:term list; -fun subte2str ss = terms2str ss; - -fun subte2sube ss = map term2str ss; - -fun subst2subs s = map (pair2str o - (apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o - (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s; -fun subst2subs' s = map ((apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o - (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s; -fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s; -(*> subs2subst thy ["(bdv,x)","(err,#0)"]; -val it = - [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")), - (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))] - : (term * term) list*) -(*["bdv=x","err=0"] ---> [(bdv,x), (err,0)]*) -fun sube2subst thy s = map (dest_equals' o term_of o the o (parse thy)) s; -(* val ts = sube2subst thy ["bdv=x","err=0"]; - subst2str' ts; - *) -fun sube2subte ss = map str2term ss; - - -fun isasub2subst isasub = ((map isapair2pair) o isalist2list) isasub; - - -type scrstate = (*state for script interpreter*) - env(*stack*) (*used to instantiate tac for checking assod - 12.03.noticed: e_ not updated during execution ?!?*) - * loc_ (*location of tac in script*) - * term option(*argument of curried functions*) - * term (*value obtained by tac executed - updated also after a derivation by 'new_val'*) - * safe (*estimation of how result will be obtained*) - * bool; (*true = strongly .., false = weakly associated: - only used during ass_dn/up*) -val e_scrstate = ([],[],NONE,e_term,Sundef,false):scrstate; - - -(*21.8.02 ---> definitions.sml for datatype scr -type rrlsstate = (*state for reverse rewriting*) - (term * (*the current formula*) - rule list (*of reverse rewrite set (#1#)*) - list * (*may be serveral, eg. in norm_rational*) - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*) - (term * (*... rewrite with ...*) - term list)) (*... assumptions*) - list); (*derivation from given term to normalform - in reverse order with sym_thm; - (#1#) could be extracted from here #1*) --------*) - -datatype istate = (*interpreter state*) - Uistate (*undefined in modspec, in '_deriv'ation*) - | ScrState of scrstate (*for script interpreter*) - | RrlsState of rrlsstate; (*for reverse rewriting*) -val e_istate = (ScrState ([],[],NONE,e_term,Sundef,false)):istate; - -type iist = istate option * istate option; -(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*) - - -fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^ - (terms2str a)^"))"; -fun istate2str Uistate = "Uistate" - | istate2str (ScrState (e,l,to,t,s,b):istate) = - "ScrState ("^ subst2str e ^",\n "^ - loc_2str l ^", "^ termopt2str to ^",\n "^ - term2str t ^", "^ safe2str s ^", "^ bool2str b ^")" - | istate2str (RrlsState (t,t1,rss,rtas)) = - "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^ - ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^ - ((strs2str o (map rta2str)) rtas)^")"; -fun istates2str (NONE, NONE) = "(#NONE, #NONE)" - | istates2str (NONE, SOME ist) = "(#NONE,\n#SOME "^istate2str ist^")" - | istates2str (SOME ist, NONE) = "(#SOME "^istate2str ist^",\n #NONE)" - | istates2str (SOME i1, SOME i2) = "(#SOME "^istate2str i1^",\n #SOME "^ - istate2str i2^")"; - -fun new_val v (ScrState (env, loc_, topt, _, safe, bool)) = - (ScrState (env, loc_, topt, v, safe, bool)) - | new_val _ _ = raise error "new_val: only for ScrState"; - -datatype con = land | lor; - - -type spec = - domID * (*WN.12.03: is replaced by thy from get_met ?FIXME? in: - specify (Init_Proof..), nxt_specify_init_calc, - assod (.SubProblem...), stac2tac (.SubProblem...)*) - pblID * - metID; -fun spec2str ((dom,pbl,met)(*:spec*)) = - "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^ - ", " ^ (strs2str met) ^ ")"; -(*> spec2str empty_spec; -val it = "(\"\", [], (\"\", \"\"))" : string *) -val empty_spec = (e_domID,e_pblID,e_metID):spec; -val e_spec = empty_spec; - - - -(*.tactics propagate the construction of the calc-tree; - there are - (a) 'specsteps' for the specify-phase, and others for the solve-phase - (b) those of the solve-phase are 'initac's and others; - initacs start with a formula different from the preceding formula. - see 'type tac_' for the internal representation of tactics.*) -datatype tac = - Init_Proof of ((cterm' list) * spec) -(*'specsteps'...*) -| Model_Problem -| Refine_Problem of pblID | Refine_Tacitly of pblID - -| Add_Given of cterm' | Del_Given of cterm' -| Add_Find of cterm' | Del_Find of cterm' -| Add_Relation of cterm' | Del_Relation of cterm' - -| Specify_Theory of domID | Specify_Problem of pblID -| Specify_Method of metID -(*...'specsteps'*) -| Apply_Method of metID -(*.creates an 'istate' in PblObj.env; in case of 'init_form' - creates a formula at ((lev_on o lev_dn) p, Frm) and in this ppobj.'loc' - 'SOME istate' (at fst of 'loc'). - As each step (in the solve-phase) has a resulting formula (at the front-end) - Apply_Method also does the 1st step in the script (an 'initac') if there - is no 'init_form' .*) -| Check_Postcond of pblID -| Free_Solve - -| Rewrite_Inst of ( subs * thm') | Rewrite of thm' - | Rewrite_Asm of thm' -| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls' -| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls' -| End_Detail (*end of script from next_tac, - in solve: switches back to parent script WN0509 drop!*) -| Derive of rls' (*an input formula using rls WN0509 drop!*) -| Calculate of string (* plus | minus | times | cancel | pow | sqrt *) -| End_Ruleset -| Substitute of sube | Apply_Assumption of cterm' list - -| Take of cterm' (*an 'initac'*) -| Take_Inst of cterm' -| Group of (con * int list ) -| Subproblem of (domID * pblID) (*an 'initac'*) -| CAScmd of cterm' (*6.6.02 URD: Function formula; WN0509 drop!*) -| End_Subproblem (*WN0509 drop!*) - -| Split_And | Conclude_And -| Split_Or | Conclude_Or -| Begin_Trans | End_Trans -| Begin_Sequ | End_Sequ(* substitute root.env *) -| Split_Intersect | End_Intersect -| Check_elementwise of cterm' | Collect_Trues -| Or_to_List - -| Empty_Tac (*TODO.11.6.03 ... of string: could carry msg of (Notappl msg) - in 'helpless'*) -| Tac of string(* eg.'repeat'*WN0509 drop!*) -| User (*internal, for ets*WN0509 drop!*) -| End_Proof';(* inout*) - -(* tac2str /--> library.sml: needed in dialog.sml for 'separable *) -fun tac2str (ma:tac) = case ma of - Init_Proof (ppc, spec) => - "Init_Proof "^(pair2str (strs2str ppc, spec2str spec)) - | Model_Problem => "Model_Problem " - | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID) - | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID) - | Add_Given cterm' => "Add_Given "^cterm' - | Del_Given cterm' => "Del_Given "^cterm' - | Add_Find cterm' => "Add_Find "^cterm' - | Del_Find cterm' => "Del_Find "^cterm' - | Add_Relation cterm' => "Add_Relation "^cterm' - | Del_Relation cterm' => "Del_Relation "^cterm' - - | Specify_Theory domID => "Specify_Theory "^(quote domID ) - | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID ) - | Specify_Method metID => "Specify_Method "^(strs2str metID) - | Apply_Method metID => "Apply_Method "^(strs2str metID) - | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID) - | Free_Solve => "Free_Solve" - - | Rewrite_Inst (subs,thm')=> - "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm')) - | Rewrite thm' => "Rewrite "^(spair2str thm') - | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm') - | Rewrite_Set_Inst (subs, rls) => - "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls)) - | Rewrite_Set rls => "Rewrite_Set "^(quote rls ) - | Detail_Set rls => "Detail_Set "^(quote rls ) - | Detail_Set_Inst (subs, rls) => - "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls)) - | End_Detail => "End_Detail" - | Derive rls' => "Derive "^rls' - | Calculate op_ => "Calculate "^op_ - | Substitute sube => "Substitute "^sube2str sube - | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's) - - | Take cterm' => "Take "^(quote cterm' ) - | Take_Inst cterm' => "Take_Inst "^(quote cterm' ) - | Group (con, ints) => - "Group "^(pair2str (con2str con, ints2str ints)) - | Subproblem (domID, pblID) => - "Subproblem "^(pair2str (domID, strs2str pblID)) -(*| Subproblem_Full (spec, cts') => - "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*) - | End_Subproblem => "End_Subproblem" - | CAScmd cterm' => "CAScmd "^(quote cterm') - - | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm') - | Or_to_List => "Or_to_List " - | Collect_Trues => "Collect_Trues" - - | Empty_Tac => "Empty_Tac" - | Tac string => "Tac "^string - | User => "User" - | End_Proof' => "tac End_Proof'" - | _ => "tac2str not impl. for ?!"; - -fun is_rewset (Rewrite_Set_Inst _) = true - | is_rewset (Rewrite_Set _) = true - | is_rewset _ = false; -fun is_rewtac (Rewrite _) = true - | is_rewtac (Rewrite_Inst _) = true - | is_rewtac (Rewrite_Asm _) = true - | is_rewtac tac = is_rewset tac; - -fun tac2IDstr (ma:tac) = case ma of - Model_Problem => "Model_Problem" - | Refine_Tacitly pblID => "Refine_Tacitly" - | Refine_Problem pblID => "Refine_Problem" - | Add_Given cterm' => "Add_Given" - | Del_Given cterm' => "Del_Given" - | Add_Find cterm' => "Add_Find" - | Del_Find cterm' => "Del_Find" - | Add_Relation cterm' => "Add_Relation" - | Del_Relation cterm' => "Del_Relation" - - | Specify_Theory domID => "Specify_Theory" - | Specify_Problem pblID => "Specify_Problem" - | Specify_Method metID => "Specify_Method" - | Apply_Method metID => "Apply_Method" - | Check_Postcond pblID => "Check_Postcond" - | Free_Solve => "Free_Solve" - - | Rewrite_Inst (subs,thm')=> "Rewrite_Inst" - | Rewrite thm' => "Rewrite" - | Rewrite_Asm thm' => "Rewrite_Asm" - | Rewrite_Set_Inst (subs, rls) => "Rewrite_Set_Inst" - | Rewrite_Set rls => "Rewrite_Set" - | Detail_Set rls => "Detail_Set" - | Detail_Set_Inst (subs, rls) => "Detail_Set_Inst" - | Derive rls' => "Derive " - | Calculate op_ => "Calculate " - | Substitute subs => "Substitute" - | Apply_Assumption ct's => "Apply_Assumption" - - | Take cterm' => "Take" - | Take_Inst cterm' => "Take_Inst" - | Group (con, ints) => "Group" - | Subproblem (domID, pblID) => "Subproblem" - | End_Subproblem => "End_Subproblem" - | CAScmd cterm' => "CAScmd" - - | Check_elementwise cterm'=> "Check_elementwise" - | Or_to_List => "Or_to_List " - | Collect_Trues => "Collect_Trues" - - | Empty_Tac => "Empty_Tac" - | Tac string => "Tac " - | User => "User" - | End_Proof' => "End_Proof'" - | _ => "tac2str not impl. for ?!"; - -fun rls_of (Rewrite_Set_Inst (_, rls)) = rls - | rls_of (Rewrite_Set rls) = rls - | rls_of tac = raise error ("rls_of: called with tac '"^tac2IDstr tac^"'"); - -fun thm_of_rew (Rewrite_Inst (subs,(thmID,_))) = - (thmID, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)) - | thm_of_rew (Rewrite (thmID,_)) = (thmID, NONE) - | thm_of_rew (Rewrite_Asm (thmID,_)) = (thmID, NONE); - -fun rls_of_rewset (Rewrite_Set_Inst (subs,rls)) = - (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)) - | rls_of_rewset (Rewrite_Set rls) = (rls, NONE) - | rls_of_rewset (Detail_Set rls) = (rls, NONE) - | rls_of_rewset (Detail_Set_Inst (subs, rls)) = - (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst)); - -fun rule2tac _ (Calc (opID, thm)) = Calculate (calID2calcID opID) - | rule2tac [] (Thm (thmID, thm)) = Rewrite (thmID, string_of_thmI thm) - | rule2tac subst (Thm (thmID, thm)) = - Rewrite_Inst (subst2subs subst, (thmID, string_of_thmI thm)) - | rule2tac [] (Rls_ rls) = Rewrite_Set (id_rls rls) - | rule2tac subst (Rls_ rls) = - Rewrite_Set_Inst (subst2subs subst, (id_rls rls)) - | rule2tac _ rule = - raise error ("rule2tac: called with '" ^ rule2str rule ^ "'"); - -type fmz_ = cterm' list; - -(*.a formalization of an example containing data - sufficient for mechanically finding the solution for the example.*) -(*FIXME.WN051014: dont store fmz = (_,spec) in the PblObj, - this is done in origin*) -type fmz = fmz_ * spec; -val e_fmz = ([],e_spec); - -(*tac_ is made from tac in applicable_in, - and carries all data necessary for generate;*) -datatype tac_ = -(* datatype tac = *) - Init_Proof' of ((cterm' list) * spec) - (* ori list !: code specify -> applicable*) -| Model_Problem' of pblID * - itm list * (*the 'untouched' pbl*) - itm list (*the casually completed met*) -| Refine_Tacitly' of pblID * (*input*) - pblID * (*the refined from applicable_in*) - domID * (*from new pbt?! filled in specify*) - metID * (*from new pbt?! filled in specify*) - itm list (*drop ! 9.03: remains [] for - Model_Problem recognizing its activation*) -| Refine_Problem' of (pblID * (itm list * (bool * Term.term) list)) - (*FIXME?040215 drop: done automatically in init_proof + Subproblem'*) -| Add_Given' of cterm' * - itm list (*updated with input in fun specify_additem*) -| Add_Find' of cterm' * - itm list (*updated with input in fun specify_additem*) -| Add_Relation' of cterm' * - itm list (*updated with input in fun specify_additem*) -| Del_Given' of cterm' | Del_Find' of cterm' | Del_Relation' of cterm' - (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*) - -| Specify_Theory' of domID -| Specify_Problem' of (pblID * (* *) - (bool * (* matches *) - (itm list * (* ppc *) - (bool * term) list))) (* preconditions *) -| Specify_Method' of metID * - ori list * (*repl. "#undef"*) - itm list (*... updated from pbl to met*) -| Apply_Method' of metID * - (term option) * (*init_form*) - istate -| Check_Postcond' of - pblID * - (term * (*returnvalue of script in solve*) - cterm' list)(*collect by get_assumptions_ in applicable_in, except if - butlast tac is Check_elementwise: take only these asms*) -| Free_Solve' - -| Rewrite_Inst' of theory' * rew_ord' * rls - * bool * subst * thm' * term * (term * term list) -| Rewrite' of theory' * rew_ord' * rls * bool * thm' * - term * (term * term list) -| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' * - term * (term * term list) -| Rewrite_Set_Inst' of theory' * bool * subst * rls * - term * (term * term list) -| Detail_Set_Inst' of theory' * bool * subst * rls * - term * (term * term list) -| Rewrite_Set' of theory' * bool * rls * term * (term * term list) -| Detail_Set' of theory' * bool * rls * term * (term * term list) -| End_Detail' of (term * (term list)) (*see End_Trans'*) -| End_Ruleset' of term -| Derive' of rls -| Calculate' of theory' * string * term * (term * thm') - (*WN.29.4.03 asm?: * term list??*) -| Substitute' of subte (*the 'substitution': terms of type bool*) - * term (*to be substituted in*) - * term (*resulting from the substitution*) -| Apply_Assumption' of term list * term - -| Take' of term | Take_Inst' of term -| Group' of (con * int list * term) -| Subproblem' of (spec * - (ori list) * (*filled in assod Subproblem'*) - term * (*-"-, headline of calc-head *) - fmz_ * - term) (*Subproblem(dom,pbl)*) -| CAScmd' of term -| End_Subproblem' of term (*???*) -| Split_And' of term | Conclude_And' of term -| Split_Or' of term | Conclude_Or' of term -| Begin_Trans' of term | End_Trans' of (term * (term list)) -| Begin_Sequ' | End_Sequ'(* substitute root.env*) -| Split_Intersect' of term | End_Intersect' of term -| Check_elementwise' of (*special case:*) - term * (*(1)the current formula: [x=1,x=...]*) - string * (*(2)the pred from Check_elementwise *) - (term * (*(3)composed from (1) and (2): {x. pred}*) - term list) (*20.5.03 assumptions*) - -| Or_to_List' of term * term (* (a | b, [a,b]) *) -| Collect_Trues' of term - -| Empty_Tac_ | Tac_ of (*for dummies*) - theory * - string * (*form*) - string * (*in Tac*) - string (*result of Tac".."*) -| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*) - -fun tac_2str ma = case ma of - Init_Proof' (ppc, spec) => - "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec)) - | Model_Problem' (pblID,_,_) => "Model_Problem' "^(strs2str pblID ) - | Refine_Tacitly'(p,prefin,domID,metID,itms)=> - "Refine_Tacitly' (" - ^(strs2str p)^", "^(strs2str prefin)^", " - ^domID^", "^(strs2str metID)^", pbl-itms)" - | Refine_Problem' ms => "Refine_Problem' ("^(*matchs2str ms*)"..."^")" -(*| Match_Problem' (pI, (ok, (itms, pre))) => - "Match_Problem' "^(spair2str (strs2str pI, - spair2str (bool2str ok, - spair2str ("itms2str_ itms", - "items2str pre"))))*) - | Add_Given' cterm' => "Add_Given' "(*^cterm'*) - | Del_Given' cterm' => "Del_Given' "(*^cterm'*) - | Add_Find' cterm' => "Add_Find' "(*^cterm'*) - | Del_Find' cterm' => "Del_Find' "(*^cterm'*) - | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*) - | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*) - - | Specify_Theory' domID => "Specify_Theory' "^(quote domID ) - | Specify_Problem' (pI, (ok, (itms, pre))) => - "Specify_Problem' "^(spair2str (strs2str pI, - spair2str (bool2str ok, - spair2str ("itms2str_ itms", - "items2str pre")))) - | Specify_Method' (pI,oris,itms) => - "Specify_Method' ("^metID2str pI^", "^oris2str oris^", )" - - | Apply_Method' (metID,_,_) => "Apply_Method' "^(strs2str metID) - | Check_Postcond' (pblID,(scval,asm)) => - "Check_Postcond' "^(spair2str(strs2str pblID, - spair2str (term2str scval, strs2str asm))) - - | Free_Solve' => "Free_Solve'" - - | Rewrite_Inst' (*subs,thm'*) _ => - "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*) - | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*) - | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*) - | Rewrite_Set_Inst' (*subs,thm'*) _ => - "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*) - | Rewrite_Set'(thy',pasm,rls',f,(f',asm)) - => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^"," - ^(Syntax.string_of_term (thy2ctxt' "Isac") f)^",("^(Syntax.string_of_term (thy2ctxt' "Isac") f') - ^","^((strs2str o (map (Syntax.string_of_term (thy2ctxt' "Isac")))) asm)^"))" - - | End_Detail' _ => "End_Detail' xxx" - | Detail_Set' _ => "Detail_Set' xxx" - | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx" - - | Derive' rls => "Derive' "^id_rls rls - | Calculate' _ => "Calculate' " - | Substitute' subs => "Substitute' "(*^(subs2str subs)*) - | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*) - - | Take' cterm' => "Take' "(*^(quote cterm' )*) - | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*) - | Group' (con, ints, _) => - "Group' "^(pair2str (con2str con, ints2str ints)) - | Subproblem' (spec, oris, _,_,pbl_form) => - "Subproblem' "(*^(pair2str (domID, strs2str ,...))*) - | End_Subproblem' _ => "End_Subproblem'" - | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*) - - | Empty_Tac_ => "Empty_Tac_" - | User' => "User'" - | Tac_ (_,form,id,result) => "Tac_ (thy,"^form^","^id^","^result^")" - | _ => "tac_2str not impl. for arg"; - -(*'executed tactics' (tac_s) with local environment etc.; - used for continuing eval script + for generate*) -type ets = - (loc_ * (* of tactic in scr, tactic (weakly) associated with tac_*) - (tac_ * (* (for generate) *) - env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready: - for handling 'parallel let'*) - env * (* with results of (ready) tacs *) - term * (* itr_arg of tactic, for upd. env at Repeat, Try*) - term * (* result value of the tac *) - safe)) - list; -val Ets = []:ets; - - -fun ets2s (l,(m,eno,env,iar,res,s)) = - "\n("^(loc_2str l)^",("^(tac_2str m)^ - ",\n ens= "^(subst2str eno)^ - ",\n env= "^(subst2str env)^ - ",\n iar= "^(Syntax.string_of_term (thy2ctxt' "Isac") iar)^ - ",\n res= "^(Syntax.string_of_term (thy2ctxt' "Isac") res)^ - ",\n "^(safe2str s)^"))"; -fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets; - - -type envp =(*9.5.03: unused, delete with field in ptree.PblObj FIXXXME*) - (int * term list) list * (*assoc-list: args of met*) - (int * rls) list * (*assoc-list: tacs already done ///15.9.00*) - (int * ets) list * (*assoc-list: tacs etc. already done*) - (string * pos) list; (*asms * from where*) -val empty_envp = ([],[],[],[]):envp; - -datatype ppobj = - PrfObj of {cell : lrd option, (*where in form tac has been applied*) - (*^^^FIXME.WN0607 rename this field*) - form : term, - tac : tac, (* also in istate*) - loc : istate option * istate option, (*for form, result -13.8.02: (NONE,NONE) <==> e_istate ! see update_loc, get_loc*) - branch: branch, - result: term * term list, - ostate: ostate} (*Complete <=> result is OK*) - | PblObj of {cell : lrd option,(*unused: meaningful only for some _Prf_Obj*) - fmz : fmz, (*from init:FIXME never use this spec;-drop*) - origin: (ori list) * (*representation from fmz+pbt - for efficiently adding items in probl, meth*) - spec * (*updated by Refine_Tacitly*) - term, (*headline of calc-head, as calculated - initially(!)*) - (*# the origin of a root-pbl is created from fmz - (thus providing help for input to the user), - # the origin of a sub-pbl is created from the argument - -list of a script-tac 'SubProblem (spec) [arg-list]' - by 'match_ags'*) - spec : spec, (*explicitly input*) - probl : itm list, (*itms explicitly input*) - meth : itm list, (*itms automatically added to copy of probl - TODO: input like to 'probl'*) - env : istate option,(*for problem with initac in script*) - loc : istate option * istate option, (*for pbl+met * result*) - branch: branch, - result: term * term list, - ostate: ostate}; (*Complete <=> result is _proven_ OK*) - -(*.this tree contains isac's calculations; TODO.WN03 rename to ctree; - the structure has been copied from an early version of Theorema(c); - it has the disadvantage, that there is no space - for the first tactic in a script generating the first formula at (p,Frm); - this trouble has been covered by 'init_form' and 'Take' so far, - but it is crucial if the first tactic in a script is eg. 'Subproblem'; - see 'type tac ', Apply_Method. -.*) -datatype ptree = - EmptyPtree - | Nd of ppobj * (ptree list); -val e_ptree = EmptyPtree; - -fun rep_prfobj (PrfObj {cell,form,tac,loc,branch,result,ostate}) = - {cell=cell,form=form,tac=tac,loc=loc,branch=branch,result=result,ostate=ostate}; -fun rep_pblobj (PblObj {cell,origin,fmz,spec,probl,meth,env, - loc,branch,result,ostate}) = - {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,meth=meth, - env=env,loc=loc,branch=branch,result=result,ostate=ostate}; -fun is_prfobj (PrfObj _) = true - | is_prfobj _ =false; -(*val is_prfobj' = get_obj is_prfobj; *) -fun is_pblobj (PblObj _) = true - | is_pblobj _ = false; -(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*) - - -exception PTREE of string; -fun nth _ [] = raise PTREE "nth _ []" - | nth 1 (x::xs) = x - | nth n (x::xs) = nth (n-1) xs; -(*> nth 2 [11,22,33]; -->> val it = 22 : int*) - -fun lev_up ([]:pos) = raise PTREE "lev_up []" - | lev_up p = (drop_last p):pos; -fun lev_on ([]:pos) = raise PTREE "lev_on []" - | lev_on pos = - let val len = length pos - in (drop_last pos) @ [(nth len pos)+1] end; -fun lev_onFrm ((p,_):pos') = (lev_on p,Frm):pos' - | lev_onFrm p = raise PTREE ("*** lev_onFrm: pos'="^(pos'2str p)); -(*040216: for inform --> embed_deriv: remains on same level*) -fun lev_back (([],_):pos') = raise PTREE "lev_on_back: called by ([],_)" - | lev_back (p,_) = - if last_elem p <= 1 then (p, Frm):pos' - else ((drop_last p) @ [(nth (length p) p) - 1], Res); -(*.increase pos by n within a level.*) -fun pos_plus 0 pos = pos - | pos_plus n ((p,Frm):pos') = pos_plus (n-1) (p, Res) - | pos_plus n ((p, _):pos') = pos_plus (n-1) (lev_on p, Res); - - - -fun lev_pred ([]:pos) = raise PTREE "lev_pred []" - | lev_pred (pos:pos) = - let val len = length pos - in ((drop_last pos) @ [(nth len pos)-1]):pos end; -(*lev_pred [1,2,3]; -val it = [1,2,2] : pos -> lev_pred [1]; -val it = [0] : pos *) - -fun lev_dn p = p @ [0]; -(*> (lev_dn o lev_on) [1,2,3]; -val it = [1,2,4,0] : pos *) -(*fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos'; WN.3.12.03: never used*) -fun lev_dnRes ((p,_):pos') = (lev_dn p, Res):pos'; - -(*4.4.00*) -fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos' - | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p')); -fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos' -fun ind ((p,_):pos') = length p; (*WN050108 deprecated in favour of lev_of*) -fun lev_of ((p,_):pos') = length p; - - -(** convert ptree to a string **) - -(* convert a pos from list to string *) -fun pr_pos ps = (space_implode "." (map string_of_int ps))^". "; -(* show hd origin or form only *) -fun pr_short (p:pos) (PblObj {origin = (ori,_,_),...}) = - ((pr_pos p) ^ " ----- pblobj -----\n") -(* ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^ - (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^ - "\n") *) - | pr_short p (PrfObj {form = form,...}) = - ((pr_pos p) ^ (term2str form) ^ "\n"); -(* -fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_,_),...}) = - ((ints2str c) ^" "^ - ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^ - (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^ - "\n") - | pr_cell p (PrfObj {cell = c, form = form,...}) = - ((ints2str c) ^" "^ (term2str form) ^ "\n"); -*) - -(* convert ptree *) -fun pr_ptree f pt = - let - fun pr_pt pfn _ EmptyPtree = "" - | pr_pt pfn ps (Nd (b, [])) = pfn ps b - | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^ - (prts pfn (ps:pos) 1 ts) - and prts pfn ps p [] = "" - | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^ - (prts pfn ps (p+1) ts) - in pr_pt f [] pt end; -(* -> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n"; -> val pt = ref EmptyPtree; -> pt:=Nd("root", - [Nd("xx1",[]), - Nd("xx2", - [Nd("xx2.1.",[]), - Nd("xx2.2.",[])]), - Nd("xx3",[])]); -> writeln (pr_ptree prfn (!pt)); -*) - - -(** access the branches of ptree **) - -fun ins_nth 1 e l = e::l - | ins_nth n e [] = raise PTREE "ins_nth n e []" - | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls); -fun repl [] _ _ = raise PTREE "repl [] _ _" - | repl (l::ls) 1 e = e::ls - | repl (l::ls) n e = l::(repl ls (n-1) e); -fun repl_app ls n e = - let val lim = 1 + length ls - in if n > lim then raise PTREE "repl_app: n > lim" - else if n = lim then ls @ [e] - else repl ls n e end; -(* -> repl [1,2,3] 2 22222; -val it = [1,22222,3] : int list -> repl_app [1,2,3,4] 5 5555; -val it = [1,2,3,4,5555] : int list -> repl_app [1,2,3] 2 22222; -val it = [1,22222,3] : int list -> repl_app [1] 2 22222 ; -val it = [1,22222] : int list -*) - - -(*.get from obj at pos by f : ppobj -> 'a.*) -fun get_obj f EmptyPtree (_:pos) = raise PTREE "get_obj f EmptyPtree" - | get_obj f (Nd (b, _)) [] = f b - | get_obj f (Nd (b, bs)) (p::ps) = -(* val (f, Nd (b, bs), (p::ps)) = (I, pt, p); - *) - let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^ - (ints2str' (p::ps))^" does not exist"); - in (get_obj f (nth p bs) (ps:pos)) - (*before WN050419: 'wrong type..' raised also if pos doesn't exist*) - handle _ => raise PTREE (*"get_obj: at pos = "^ - (ints2str' (p::ps))^" wrong type of ppobj"*) - ("get_obj: pos = "^ - (ints2str' (p::ps))^" does not exist") - end; -fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree" - | get_nd n [] = n - | get_nd (Nd (_,nds)) (pos as p::(ps:pos)) = (get_nd (nth p nds) ps) - handle _ => raise PTREE ("get_nd: not existent pos = "^(ints2str' pos)); - - -(* for use by get_obj *) -fun g_cell (PblObj {cell = c,...}) = NONE - | g_cell (PrfObj {cell = c,...}) = c;(*WN0607 hack for quick introduction of lrd + rewrite-at (thms, calcs)*) -fun g_form (PrfObj {form = f,...}) = f - | g_form (PblObj {origin=(_,_,f),...}) = f; -fun g_form' (Nd (PrfObj {form = f,...}, _)) = f - | g_form' (Nd (PblObj {origin=(_,_,f),...}, _)) = f; -(* | g_form _ = raise PTREE "g_form not for PblObj";*) -fun g_origin (PblObj {origin = ori,...}) = ori - | g_origin _ = raise PTREE "g_origin not for PrfObj"; -fun g_fmz (PblObj {fmz = f,...}) = f - | g_fmz _ = raise PTREE "g_fmz not for PrfObj"; -fun g_spec (PblObj {spec = s,...}) = s - | g_spec _ = raise PTREE "g_spec not for PrfObj"; -fun g_pbl (PblObj {probl = p,...}) = p - | g_pbl _ = raise PTREE "g_pbl not for PrfObj"; -fun g_met (PblObj {meth = p,...}) = p - | g_met _ = raise PTREE "g_met not for PrfObj"; -fun g_domID (PblObj {spec = (d,_,_),...}) = d - | g_domID _ = raise PTREE "g_metID not for PrfObj"; -fun g_metID (PblObj {spec = (_,_,m),...}) = m - | g_metID _ = raise PTREE "g_metID not for PrfObj"; -fun g_env (PblObj {env,...}) = env - | g_env _ = raise PTREE "g_env not for PrfObj"; -fun g_loc (PblObj {loc = l,...}) = l - | g_loc (PrfObj {loc = l,...}) = l; -fun g_branch (PblObj {branch = b,...}) = b - | g_branch (PrfObj {branch = b,...}) = b; -fun g_tac (PblObj {spec = (d,p,m),...}) = Apply_Method m - | g_tac (PrfObj {tac = m,...}) = m; -fun g_result (PblObj {result = r,...}) = r - | g_result (PrfObj {result = r,...}) = r; -fun g_res (PblObj {result = (r,_),...}) = r - | g_res (PrfObj {result = (r,_),...}) = r; -fun g_res' (Nd (PblObj {result = (r,_),...}, _)) = r - | g_res' (Nd (PrfObj {result = (r,_),...}, _)) = r; -fun g_ostate (PblObj {ostate = r,...}) = r - | g_ostate (PrfObj {ostate = r,...}) = r; -fun g_ostate' (Nd (PblObj {ostate = r,...}, _)) = r - | g_ostate' (Nd (PrfObj {ostate = r,...}, _)) = r; - -fun gpt_cell (Nd (PblObj {cell = c,...},_)) = NONE - | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c; - -(*in CalcTree/Subproblem an 'just_created_' model is created; - this is filled to 'untouched' by Model/Refine_Problem*) -fun just_created_ (PblObj {meth, probl, spec, ...}) = - null meth andalso null probl andalso spec = e_spec; -val e_origin = ([],e_spec,e_term): (ori list) * spec * term; - -fun just_created (pt,(p,_):pos') = - let val ppobj = get_obj I pt p - in is_pblobj ppobj andalso just_created_ ppobj end; - -(*.does the pos in the ctree exist ?.*) -fun existpt pos pt = can (get_obj I pt) pos; -(*.does the pos' in the ctree exist, ie. extra check for result in the node.*) -fun existpt' ((p,p_):pos') pt = - if can (get_obj I pt) p - then case p_ of - Res => get_obj g_ostate pt p = Complete - | _ => true - else false; - -(*.is this position appropriate for calculating intermediate steps?.*) -fun is_interpos ((_, Res):pos') = true - | is_interpos _ = false; - -fun last_onlev pt pos = not (existpt (lev_on pos) pt); - - -(*.find the position of the next parent which is a PblObj in ptree.*) -fun par_pblobj pt ([]:pos) = ([]:pos) - | par_pblobj pt p = - let fun par pt [] = [] - | par pt p = if is_pblobj (get_obj I pt p) then p - else par pt (lev_up p) - in par pt (lev_up p) end; -(* lev_up for hard_gen operating with pos = [...,0] *) - -(*.find the position and the children of the next parent which is a PblObj.*) -fun par_children (Nd (PblObj _, children)) ([]:pos) = (children, []:pos) - | par_children (pt as Nd (PblObj _, children)) p = - let fun par [] = (children, []) - | par p = let val Nd (obj, children) = get_nd pt p - in if is_pblobj obj then (children, p) else par (lev_up p) - end; - in par (lev_up p) end; - -(*.get the children of a node in ptree.*) -fun children (Nd (PblObj _, cn)) = cn - | children (Nd (PrfObj _, cn)) = cn; - - -(*.find the next parent, which is either a PblObj (return true) - or a PrfObj with tac = Detail_Set (return false).*) -(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*) -fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls) - | par_pbl_det pt p = - let fun par pt [] = (true, [], Erls) - | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls) - else case get_obj g_tac pt p of - (*Detail_Set rls' => (false, p, assoc_rls rls') - (*^^^--- before 040206 after ---vvv*) - |*)Rewrite_Set rls' => (false, p, assoc_rls rls') - | Rewrite_Set_Inst (_, rls') => - (false, p, assoc_rls rls') - | _ => par pt (lev_up p) - in par pt (lev_up p) end; - - - - -(*.get from the whole ptree by f : ppobj -> 'a.*) -fun get_all f EmptyPtree = [] - | get_all f (Nd (b, [])) = [f b] - | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs) -and get_alls f [] = [] - | get_alls f pts = flat (map (get_all f) pts); - - -(*.insert obj b into ptree at pos, ev.overwriting this pos.*) -fun insert b EmptyPtree ([]:pos) = Nd (b, []) - | insert b EmptyPtree _ = raise PTREE "insert b Empty _" - | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []" - | insert b (Nd (b', bs)) (p::[]) = - Nd (b', repl_app bs p (Nd (b,[]))) - | insert b (Nd (b', bs)) (p::ps) = - Nd (b', repl_app bs p (insert b (nth p bs) ps)); -(* -> type ppobj = string; -> writeln (pr_ptree prfn (!pt)); - val pt = ref Empty; - pt:= insert ("root":ppobj) EmptyPtree []; - pt:= insert ("xx1":ppobj) (!pt) [1]; - pt:= insert ("xx2":ppobj) (!pt) [2]; - pt:= insert ("xx3":ppobj) (!pt) [3]; - pt:= insert ("xx2.1":ppobj) (!pt) [2,1]; - pt:= insert ("xx2.2":ppobj) (!pt) [2,2]; - pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1]; - pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2]; - pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3]; -*) - -(*.insert children to a node without children.*) -(*compare: fun insert*) -fun ins_chn _ EmptyPtree (_:pos) = raise PTREE "ins_chn: EmptyPtree" - | ins_chn ns (Nd _) [] = raise PTREE "ins_chn: pos = []" - | ins_chn ns (Nd (b, bs)) (p::[]) = - if p > length bs then raise PTREE "ins_chn: pos not existent" - else let val Nd (b', bs') = nth p bs - in if null bs' then Nd (b, repl_app bs p (Nd (b', ns))) - else raise PTREE "ins_chn: pos mustNOT be overwritten" end - | ins_chn ns (Nd (b, bs)) (p::ps) = - Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps)); - -(* print_depth 11;ins_chn;print_depth 3; ###insert#########################*); - - -(** apply f to obj at pos, f: ppobj -> ppobj **) - -fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs); -fun appl_obj f EmptyPtree [] = EmptyPtree - | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _" - | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs) - | appl_obj f (Nd (b, bs)) (p::[]) = - Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs)) - | appl_obj f (Nd (b, bs)) (p::ps) = - Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos))); - -(* for use by appl_obj *) -fun repl_form f (PrfObj {cell=c,form= _,tac=tac,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PrfObj {cell=c,form= f,tac=tac,loc=loc, - branch=branch,result=result,ostate=ostate} - | repl_form _ _ = raise PTREE "repl_form takes no PblObj"; -fun repl_pbl x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=_,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl= x, - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj"; -fun repl_met x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=_,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, - meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj"; - -fun repl_spec x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec= _,probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec= x,probl=probl, - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj"; -fun repl_domID x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(x,p,m),probl=probl, - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj"; -fun repl_pblID x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,x,m),probl=probl, - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj"; -fun repl_metID x (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,p,x),probl=probl, - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate} - | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj"; - -fun repl_result l f' s (PrfObj {cell=cell,form=form,tac=tac,loc=_, - branch=branch,result = _ ,ostate = _}) = - PrfObj {cell=cell,form=form,tac=tac,loc= l, - branch=branch,result = f',ostate = s} - | repl_result l f' s (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=_, - branch=branch,result= _ ,ostate= _}) = - PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc= l, - branch=branch,result= f',ostate= s}; - -fun repl_tac x (PrfObj {cell=cell,form=form,tac= _,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PrfObj {cell=cell,form=form,tac= x,loc=loc, - branch=branch,result=result,ostate=ostate} - | repl_tac _ _ = raise PTREE "repl_tac takes no PblObj"; - -fun repl_branch b (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=loc, - branch= _,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, - meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate} - | repl_branch b (PrfObj {cell=cell,form=form,tac=tac,loc=loc, - branch= _,result=result,ostate=ostate}) = - PrfObj {cell=cell,form=form,tac=tac,loc=loc, - branch= b,result=result,ostate=ostate}; - -fun repl_env e - (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=_,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, - meth=meth,env=e,loc=loc,branch=branch, - result=result,ostate=ostate} - | repl_env _ _ = raise PTREE "repl_ets takes no PrfObj"; - -fun repl_oris oris - (PblObj {cell=cell,origin=(_,spe,hdf),fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl, - meth=meth,env=env,loc=loc,branch=branch, - result=result,ostate=ostate} - | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj"; -fun repl_orispec spe - (PblObj {cell=cell,origin=(oris,_,hdf),fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl, - meth=meth,env=env,loc=loc,branch=branch, - result=result,ostate=ostate} - | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj"; - -fun repl_loc l (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=_, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl, - meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate} - | repl_loc l (PrfObj {cell=cell,form=form,tac=tac,loc=_, - branch=branch,result=result,ostate=ostate}) = - PrfObj {cell=cell,form=form,tac=tac,loc= l, - branch=branch,result=result,ostate=ostate}; -(* -fun uni__cid cell' - (PblObj {cell=cell,origin=origin,fmz=fmz, - spec=spec,probl=probl,meth=meth,env=env,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PblObj {cell=cell union cell',origin=origin,fmz=fmz,spec=spec,probl=probl, - meth=meth,env=env,loc=loc,branch=branch, - result=result,ostate=ostate} - | uni__cid cell' - (PrfObj {cell=cell,form=form,tac=tac,loc=loc, - branch=branch,result=result,ostate=ostate}) = - PrfObj {cell=cell union cell',form=form,tac=tac,loc=loc, - branch=branch,result=result,ostate=ostate}; -*) - -(*WN050219 put here for interpreting code for cut_tree below...*) -type ocalhd = - bool * (*ALL itms+preconds true*) - pos_ * (*model belongs to Problem | Method*) - term * (*header: Problem... or Cas - FIXXXME.12.03: item! for marking syntaxerrors*) - itm list * (*model: given, find, relate*) - ((bool * term) list) *(*model: preconds*) - spec; (*specification*) -val e_ocalhd = (false, Und, e_term, [e_itm], [(false, e_term)], e_spec); - -datatype ptform = - Form of term - | ModSpec of ocalhd; -val e_ptform = Form e_term; -val e_ptform' = ModSpec e_ocalhd; - - - -(*.applies (snd f) to the branches at a pos if ((fst f) b), - f : (ppobj -> bool) * (int -> ptree list -> ptree list).*) - -fun appl_branch f EmptyPtree [] = (EmptyPtree, false) - | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _" - | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []" - | appl_branch f (Nd (b, bs)) (p::[]) = - if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true) - else (Nd (b, bs), false) - | appl_branch f (Nd (b, bs)) (p::ps) = - let val (b',bool) = appl_branch f (nth p bs) ps - in (Nd (b, repl_app bs p b'), bool) end; - -(* for cut_level; appl_branch(deprecated) *) -fun test_trans (PrfObj{branch = Transitive,...}) = true - | test_trans (PblObj{branch = Transitive,...}) = true - | test_trans _ = false; - -fun is_pblobj' pt (p:pos) = - let val ppobj = get_obj I pt p - in is_pblobj ppobj end; - - -fun delete_result pt (p:pos) = - (appl_obj (repl_result (fst (get_obj g_loc pt p), NONE) - (e_term,[]) Incomplete) pt p); - -fun del_res (PblObj {cell, fmz, origin, spec, probl, meth, - env, loc=(l1,_), branch, result, ostate}) = - PblObj {cell=cell,fmz=fmz,origin=origin,spec=spec,probl=probl,meth=meth, - env=env, loc=(l1,NONE), branch=branch, result=(e_term,[]), - ostate=Incomplete} - - | del_res (PrfObj {cell, form, tac, loc=(l1,_), branch, result, ostate}) = - PrfObj {cell=cell,form=form,tac=tac, loc=(l1,NONE), branch=branch, - result=(e_term,[]), ostate=Incomplete}; - - -(* -fun update_fmz pt pos x = appl_obj (repl_fmz x) pt pos; - 1.00 not used anymore*) - -(*FIXME.WN.12.03: update_X X pos pt -> pt could be chained by o (efficiency?)*) -fun update_env pt pos x = appl_obj (repl_env x) pt pos; -fun update_domID pt pos x = appl_obj (repl_domID x) pt pos; -fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos; -fun update_metID pt pos x = appl_obj (repl_metID x) pt pos; -fun update_spec pt pos x = appl_obj (repl_spec x) pt pos; - -fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos; -fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos; - -fun update_met pt pos x = appl_obj (repl_met x) pt pos; -(*1.09.01 ---- -fun update_metppc pt pos x = - let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} = - get_obj g_met pt pos - in appl_obj (repl_met - {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x}) - pt pos end;*) -fun update_metppc pt pos x = appl_obj (repl_met x) pt pos; - -(*fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;*) - -fun update_branch pt pos x = appl_obj (repl_branch x) pt pos; -fun update_tac pt pos x = appl_obj (repl_tac x) pt pos; - -fun update_oris pt pos x = appl_obj (repl_oris x) pt pos; -fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos; - - (*done by append_* !! 3.5.02; ununsed WN050305 thus outcommented -fun update_loc pt (p,_) (ScrState ([],[],NONE, - Const ("empty",_),Sundef,false)) = - appl_obj (repl_loc (NONE,NONE)) pt p - | update_loc pt (p,Res) x = - let val (lform,_) = get_obj g_loc pt p - in appl_obj (repl_loc (lform,SOME x)) pt p end - - | update_loc pt (p,_) x = - let val (_,lres) = get_obj g_loc pt p - in appl_obj (repl_loc (SOME x,lres)) pt p end;-------------*) - -(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*) -fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p; - -(*13.8.02--------------------------- -fun get_loc EmptyPtree _ = NONE - | get_loc pt (p,Res) = - let val (lfrm,lres) = get_obj g_loc pt p - in if lres = e_istate then lfrm else lres end - | get_loc pt (p,_) = - let val (lfrm,lres) = get_obj g_loc pt p - in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*) -(*13.8.02: options, because istate is no equalitype any more*) -fun get_loc EmptyPtree _ = e_istate - | get_loc pt (p,Res) = - (case get_obj g_loc pt p of - (SOME i, NONE) => i - | (NONE , NONE) => e_istate - | (_ , SOME i) => i) - | get_loc pt (p,_) = - (case get_obj g_loc pt p of - (NONE , SOME i) => i (*13.8.02 just copied from ^^^: too liberal ?*) - | (NONE , NONE) => e_istate - | (SOME i, _) => i); -val get_istate = get_loc; (*3.5.02*) - -(*.collect the assumptions within a problem up to a certain position.*) -type asms = (term * pos) list;(*WN0502 should be (pos' * term) list - ...........===^===*) - -fun get_asm (b:pos, p:pos) (Nd (PblObj {result=(_,asm),...},_)) = - ((*writeln ("### get_asm PblObj:(b,p)= "^ - (pair2str(ints2str b, ints2str p)));*) - (map (rpair b) asm):asms) - | get_asm (b, p) (Nd (PrfObj {result=(_,asm),...}, [])) = - ((*writeln ("### get_asm PrfObj []:(b,p)= "^ - (pair2str(ints2str b, ints2str p)));*) - (map (rpair b) asm)) - | get_asm (b, p:pos) (Nd (PrfObj _, nds)) = - let (*val _= writeln ("### get_asm PrfObj nds:(b,p)= "^ - (pair2str(ints2str b, ints2str p)));*) - val levdn = - if p <> [] then (b @ [hd p]:pos, tl p:pos) - else (b @ [1], [99999]) (*_deeper_ nesting is always _before_ p*) - in gets_asm levdn 1 nds end -and gets_asm _ _ [] = [] - | gets_asm (b, p' as p::ps) i (nd::nds) = - if p < i then [] - else ((*writeln ("### gets_asm: (b,p')= "^(pair2str(ints2str b, - ints2str p')));*) - (get_asm (b @ [i], ps) nd) @ (gets_asm (b, p') (i + 1) nds)); - -fun get_assumptions_ (Nd (PblObj {result=(r,asm),...}, cn)) (([], _):pos') = - if r = e_term then gets_asm ([], [99999]) 1 cn - else map (rpair []) asm - | get_assumptions_ pt (p,p_) = - let val (cn, base) = par_children pt p - val offset = drop (length base, p) - val base' = replicate (length base) 1 - val offset' = case p_ of - Frm => let val (qs,q) = split_last offset - in qs @ [q - 1] end - | _ => offset - (*val _= writeln ("... get_assumptions: (b,o)= "^ - (pair2str(ints2str base',ints2str offset)))*) - in gets_asm (base', offset) 1 cn end; - - -(*--------- -end - -open Ptree; -----------*) - -(*pos of the formula on FE relative to the current pos, - which is the next writepos*) -fun pre_pos ([]:pos) = []:pos - | pre_pos pp = - let val (ps,p) = split_last pp - in case p of 1 => ps | n => ps @ [n-1] end; - -(*WN.20.5.03 ... but not used*) -fun posless [] (_::_) = true - | posless (_::_) [] = false - | posless (p::ps) (q::qs) = if p = q then posless ps qs else p < q; -(* posless [2,3,4] [3,4,5]; -true -> posless [2,3,4] [1,2,3]; -false -> posless [2,3] [2,3,4]; -true -> posless [2,3,4] [2,3]; -false -> posless [6] [6,5,2]; -true -+++ see Isabelle/../library.ML*) - - -(**.development for extracting an 'interval' from ptree.**) - -(*version 1 stopped 8.03 in favour of get_interval with !!!move_dn - actually used (inefficient) version with move_dn: see modspec.sml*) -local - -fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*) -fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*) -fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x; -fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x; - -fun getnd i (b,p) q (Nd (po, nds)) = - (if i <= 0 then [[b]] else []) @ - (getnds (i-1) true (b@[hdp p], tlp p) (tlq q) - (take_fromto (hdp p) (hdq q) nds)) - -and getnds _ _ _ _ [] = [] (*no children*) - | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*) - - | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*) - (getnd i ( b, p ) [99999] n1) @ - (getnd ~99999 (lev_on b,[0]) q n2) - - | getnds i _ (b,p) q [n1, n2] = (*intern, r-margin*) - (getnd i ( b,[0]) [99999] n1) @ - (getnd ~99999 (lev_on b,[0]) q n2) - - | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*) - (getnd i ( b, p ) [99999] nd) @ - (getnds ~99999 false (lev_on b,[0]) q nds) - - | getnds i _ (b,p) q (nd::(nds as _::_)) = (*intern, ...*) - (getnd i ( b,[0]) [99999] nd) @ - (getnds ~99999 false (lev_on b,[0]) q nds); -in -(*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes - where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous) -(1) the 'f' are given -(1a) by 'from' if 'f' = the respective element of 'from' (left margin) -(1b) -inifinity, if 'f' > the respective element of 'from' (internal node) -(2) the 't' ar given -(2a) by 'to' if 't' = the respective element of 'to' (right margin) -(2b) inifinity, if 't' < the respective element of 'to (internal node)' -the 'f' and 't' are set by hdp,... *) -fun get_trace pt p q = - (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q))) - (take_fromto (hdp p) (hdq q) (children pt)); -end; -(*WN0510 stoppde this development; - actually used (inefficient) version with move_dn: getFormulaeFromTo*) - - - - -fun get_somespec ((dI,pI,mI):spec) ((dI',pI',mI'):spec) = - let val domID = if dI = e_domID - then if dI' = e_domID - then raise error"pt_extract: no domID in probl,origin" - else dI' - else dI - val pblID = if pI = e_pblID - then if pI' = e_pblID - then raise error"pt_extract: no pblID in probl,origin" - else pI' - else pI - val metID = if mI = e_metID - then if pI' = e_metID - then raise error"pt_extract: no metID in probl,origin" - else mI' - else mI - in (domID, pblID, metID):spec end; -fun get_somespec' ((dI,pI,mI):spec) ((dI',pI',mI'):spec) = - let val domID = if dI = e_domID then dI' else dI - val pblID = if pI = e_pblID then pI' else pI - val metID = if mI = e_metID then mI' else mI - in (domID, pblID, metID):spec end; - -(*extract a formula or model from ptree for itms2itemppc or model2xml*) -fun preconds2str bts = - (strs2str o (map (linefeed o pair2str o - (apsnd term2str) o - (apfst bool2str)))) bts; -fun ocalhd2str ((b, p, hdf, itms, prec, spec):ocalhd) = - "("^bool2str b^", "^pos_2str p^", "^term2str hdf^ - ", "^itms2str_ (thy2ctxt' "Isac") itms^ - ", "^preconds2str prec^", \n"^spec2str spec^" )"; - - - -fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj; - - -(**.functions for the 'ptree iterator' as seen from the FE-Kernel interface.**) - -(*move one step down into existing nodes of ptree; regard TransitiveB -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~################## -fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*) -(* val (Nd (c, ns), ([],p_)) = (pt, get_pos cI uI); - *) - if is_pblobj c - then case p_ of (*Frm => ([], Pbl) 1.12.03 - |*) Res => raise PTREE "move_dn: end of calculation" - | _ => if null ns (*go down from Pbl + Met*) - then raise PTREE "move_dn: solve problem not started" - else ([1], Frm) - else (case p_ of Res => raise PTREE "move_dn: end of (sub-)tree" - | _ => if null ns - then raise PTREE "move_dn: pos not existent 1" - else ([1], Frm)) - - (*iterate towards end of pos*) -(* val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ([]:pos, pt, get_pos cI uI); - val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ((P@[p]),(nth p ns),(ps, p_)); - *) - | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) = - if p > length ns then raise PTREE "move_dn: pos not existent 2" - else move_dn ((P@[p]): pos) (nth p ns) (ps, p_) -(* val (P, (Nd (c, ns)), ([p], p_)) = ((P@[p]), (nth p ns), (ps, p_)); - val (P, (Nd (c, ns)), ([p], p_)) = ([],pt,get_pos cI uI); - *) - | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) - if p > length ns then raise PTREE "move_dn: pos not existent 3" - else if is_pblnd (nth p ns) then - ((*writeln("### move_dn: is_pblnd (nth p ns), P= "^ints2str' P^", \n"^ - "length ns= "^((string_of_int o length) ns)^ - ", p= "^string_of_int p^", p_= "^pos_2str p_);*) - case p_ of Res => if p = length ns - then if g_ostate c = Complete then (P, Res) - else raise PTREE (ints2str' P^" not complete") - (*FIXME here handle not-sequent-branches*) - else if g_branch c = TransitiveB - andalso (not o is_pblnd o (nth (p+1))) ns - then (P@[p+1], Res) - else (P@[p+1], if is_pblnd (nth (p+1) ns) - then Pbl else Frm) - | _ => if (null o children o (nth p)) ns (*go down from Pbl*) - then raise PTREE "move_dn: solve subproblem not started" - else (P @ [p, 1], - if (is_pblnd o hd o children o (nth p)) ns - then Pbl else Frm) - ) - (* val (P, Nd (c, ns), ([p], p_)) = ([], pt, ([1], Frm)); - *) - else case p_ of Frm => if (null o children o (nth p)) ns - (*then if g_ostate c = Complete then (P@[p],Res)*) - then if g_ostate' (nth p ns) = Complete - then (P@[p],Res) - else raise PTREE "move_dn: pos not existent 4" - else (P @ [p, 1], (*go down*) - if (is_pblnd o hd o children o (nth p)) ns - then Pbl else Frm) - | Res => if p = length ns - then - if g_ostate c = Complete then (P, Res) - else raise PTREE (ints2str' P^" not complete") - else - if g_branch c = TransitiveB - andalso (not o is_pblnd o (nth (p+1))) ns - then if (null o children o (nth (p+1))) ns - then (P@[p+1], Res) - else (P@[p+1,1], Frm)(*040221*) - else (P@[p+1], if is_pblnd (nth (p+1) ns) - then Pbl else Frm); -*) -(*.move one step down into existing nodes of ptree; skip Res = Frm.nxt; - move_dn at the end of the calc-tree raises PTREE.*) -fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*) - (case p_ of - Res => raise PTREE "move_dn: end of calculation" - | _ => if null ns (*go down from Pbl + Met*) - then raise PTREE "move_dn: solve problem not started" - else ([1], Frm)) - | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =(*iterate to end of pos*) - if p > length ns then raise PTREE "move_dn: pos not existent 2" - else move_dn ((P@[p]): pos) (nth p ns) (ps, p_) - - | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) - if p > length ns then raise PTREE "move_dn: pos not existent 3" - else case p_ of - Res => - if p = length ns (*last Res on this level: go a level up*) - then if g_ostate c = Complete then (P, Res) - else raise PTREE (ints2str' P^" not complete 1") - else (*go to the next Nd on this level, or down into the next Nd*) - if is_pblnd (nth (p+1) ns) then (P@[p+1], Pbl) - else - if g_res' (nth p ns) = g_form' (nth (p+1) ns) - then if (null o children o (nth (p+1))) ns - then (*take the Res if Complete*) - if g_ostate' (nth (p+1) ns) = Complete - then (P@[p+1], Res) - else raise PTREE (ints2str' (P@[p+1])^ - " not complete 2") - else (P@[p+1,1], Frm)(*go down into the next PrfObj*) - else (P@[p+1], Frm)(*take Frm: exists if the Nd exists*) - | Frm => (*go down or to the Res of this Nd*) - if (null o children o (nth p)) ns - then if g_ostate' (nth p ns) = Complete then (P @ [p], Res) - else raise PTREE (ints2str' (P @ [p])^" not complete 3") - else (P @ [p, 1], Frm) - | _ => (*is Pbl or Met*) - if (null o children o (nth p)) ns - then raise PTREE "move_dn:solve subproblem not startd" - else (P @ [p, 1], - if (is_pblnd o hd o children o (nth p)) ns - then Pbl else Frm); - - -(*.go one level down into ptree.*) -fun movelevel_dn [] (Nd (c, ns)) ([],p_) = (*root problem*) - if is_pblobj c - then if null ns - then raise PTREE "solve problem not started" - else ([1], if (is_pblnd o hd) ns then Pbl else Frm) - else raise PTREE "pos not existent 1" - - (*iterate towards end of pos*) - | movelevel_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) = - if p > length ns then raise PTREE "pos not existent 2" - else movelevel_dn (P@[p]) (nth p ns) (ps, p_) - - | movelevel_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) - if p > length ns then raise PTREE "pos not existent 3" else - case p_ of Res => - if p = length ns - then raise PTREE "no children" - else - if g_branch c = TransitiveB - then if (null o children o (nth (p+1))) ns - then raise PTREE "no children" - else (P @ [p+1, 1], - if (is_pblnd o hd o children o (nth (p+1))) ns - then Pbl else Frm) - else if (null o children o (nth p)) ns - then raise PTREE "no children" - else (P @ [p, 1], if (is_pblnd o hd o children o (nth p)) ns - then Pbl else Frm) - | _ => if (null o children o (nth p)) ns - then raise PTREE "no children" - else (P @ [p, 1], (*go down*) - if (is_pblnd o hd o children o (nth p)) ns - then Pbl else Frm); - - - -(*.go to the previous position in ptree; regard TransitiveB.*) -fun move_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*) - if is_pblobj c - then case p_ of Res => if null ns then ([], Pbl) (*Res -> Pbl (not Met)!*) - else ([length ns], Res) - | _ => raise PTREE "begin of calculation" - else raise PTREE "pos not existent" - - | move_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = (*iterate to end of pos*) - if p > length ns then raise PTREE "pos not existent" - else move_up (P@[p]) (nth p ns) (ps,p_) - - | move_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) - if p > length ns then raise PTREE "pos not existent" - else if is_pblnd (nth p ns) then - case p_ of Res => - let val nc = (length o children o (nth p)) ns - in if nc = 0 then (P@[p], Pbl) (*Res -> Pbl (not Met)!*) - else (P @ [p, nc], Res) end (*go down*) - | _ => if p = 1 then (P, Pbl) else (P@[p-1], Res) - else case p_ of Frm => if p <> 1 then (P, Frm) - else if is_pblobj c then (P, Pbl) else (P, Frm) - | Res => - let val nc = (length o children o (nth p)) ns - in if nc = 0 (*cannot go down*) - then if g_branch c = TransitiveB andalso p <> 1 - then (P@[p-1], Res) else (P@[p], Frm) - else (P @ [p, nc], Res) end; (*go down*) - - - -(*.go one level up in ptree; sets the position on Frm.*) -fun movelevel_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*) - raise PTREE "pos not existent" - - (*iterate towards end of pos*) - | movelevel_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = - if p > length ns then raise PTREE "pos not existent" - else movelevel_up (P@[p]) (nth p ns) (ps,p_) - - | movelevel_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*) - if p > length ns then raise PTREE "pos not existent" - else if is_pblobj c then (P, Pbl) else (P, Frm); - - -(*.go to the next calc-head up in the calc-tree.*) -fun movecalchd_up pt ((p, Res):pos') = - (par_pblobj pt p, Pbl):pos' - | movecalchd_up pt (p, _) = - if is_pblobj (get_obj I pt p) - then (p, Pbl) else (par_pblobj pt p, Pbl); - -(*.determine the previous pos' on the same level.*) -(*WN0502 made for interSteps; _only_ works for branch TransitiveB*) -fun lev_pred' pt (pos:pos' as ([],Res)) = ([],Pbl):pos' - | lev_pred' pt (pos:pos' as (p, Res)) = - let val (p', last) = split_last p - in if last = 1 - then if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm) - else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p - then (p' @ [last - 1], Res) (*TransitiveB*) - else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm) - end; - -(*.determine the next pos' on the same level.*) -fun lev_on' pt (([],Pbl):pos') = ([],Res):pos' - | lev_on' pt (p, Res) = - if get_obj g_res pt p = get_obj g_form pt (lev_on p)(*TransitiveB*) - then if existpt' (lev_on p, Res) pt then (lev_on p, Res) - else raise error ("lev_on': (p, Res) -> (p, Res) not existent, \ - \p = "^ints2str' (lev_on p)) - else (lev_on p, Frm) - | lev_on' pt (p, _) = - if existpt' (p, Res) pt then (p, Res) - else raise error ("lev_on': (p, Frm) -> (p, Res) not existent, \ - \p = "^ints2str' p); - -fun exist_lev_on' pt p = (lev_on' pt p; true) handle _ => false; - -(*.is the pos' at the last element of a calulation _AND_ can be continued.*) -(* val (pt, pos as (p,p_)) = (pt, ([1],Frm)); - *) -fun is_curr_endof_calc pt (([],Res) : pos') = false - | is_curr_endof_calc pt (pos as (p,_)) = - not (exist_lev_on' pt pos) - andalso get_obj g_ostate pt (lev_up p) = Incomplete; - - -(**.insert into ctree and cut branches accordingly.**) - -(*.get all positions of certain intervals on the ctree.*) -(*OLD VERSION without move_dn; kept for occasional redesign - get all pos's to be cut in a ptree - below a pos or from a ptree list after i-th element (NO level_up).*) -fun get_allpos' (_:pos, _:posel) EmptyPtree = ([]:pos' list) - | get_allpos' (p, 1) (Nd (b, bs)) = (*p is pos of Nd*) - if g_ostate b = Incomplete - then ((*writeln("get_allpos' (p, 1) Incomplete: p="^ints2str' p);*) - [(p,Frm)] @ (get_allpos's (p, 1) bs) - ) - else ((*writeln("get_allpos' (p, 1) else: p="^ints2str' p);*) - [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)] - ) - (*WN041020 here we assume what is presented on the worksheet ?!*) - | get_allpos' (p, i) (Nd (b, bs)) = (*p is pos of Nd*) - if length bs > 0 orelse is_pblobj b - then if g_ostate b = Incomplete - then [(p,Frm)] @ (get_allpos's (p, 1) bs) - else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)] - else - if g_ostate b = Incomplete - then [] - else [(p,Res)] -(*WN041020 here we assume what is presented on the worksheet ?!*) -and get_allpos's _ [] = [] - | get_allpos's (p, i) (pt::pts) = (*p is pos of parent-Nd*) - (get_allpos' (p@[i], i) pt) @ (get_allpos's (p, i+1) pts); - -(*.get all positions of certain intervals on the ctree.*) -(*NEW version WN050225*) - - -(*.cut branches.*) -(*before WN041019...... -val cut_branch = (test_trans, curry take): - (ppobj -> bool) * (int -> ptree list -> ptree list); -.. formlery used for ... -fun cut_tree''' _ [] = EmptyPtree - | cut_tree''' pt pos = - let val (pt',cut) = appl_branch cut_branch pt pos - in if cut andalso length pos > 1 then cut_tree''' pt' (lev_up pos) - else pt' end; -*) -(*OLD version before WN050225*) -(*WN050106 like cut_level, but deletes exactly 1 node --- for tests ONLY*) -fun cut_level_'_ (_:pos' list) (_:pos) EmptyPtree (_:pos') = - raise PTREE "cut_level_'_ Empty _" - | cut_level_'_ _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level_'_ _ []" - | cut_level_'_ cuts P (Nd (b, bs)) (p::[],p_) = - if test_trans b - then (Nd (b, drop_nth [] (p:posel, bs)), - (* ~~~~~~~~~~~*) - cuts @ - (if p_ = Frm then [(P@[p],Res)] else ([]:pos' list)) @ - (*WN041020 here we assume what is presented on the worksheet ?!*) - (get_allpos's (P, p+1) (drop_nth [] (p, bs)))) - (* ~~~~~~~~~~~*) - else (Nd (b, bs), cuts) - | cut_level_'_ cuts P (Nd (b, bs)) ((p::ps),p_) = - let val (bs',cuts') = cut_level_'_ cuts P (nth p bs) (ps, p_) - in (Nd (b, repl_app bs p bs'), cuts @ cuts') end; - -(*before WN050219*) -fun cut_level (_:pos' list) (_:pos) EmptyPtree (_:pos') = - raise PTREE "cut_level EmptyPtree _" - | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []" - - | cut_level cuts P (Nd (b, bs)) (p::[],p_) = - if test_trans b - then (Nd (b, take (p:posel, bs)), - cuts @ - (if p_ = Frm andalso (*#*) g_ostate b = Complete - then [(P@[p],Res)] else ([]:pos' list)) @ - (*WN041020 here we assume what is presented on the worksheet ?!*) - (get_allpos's (P, p+1) (takerest (p, bs)))) - else (Nd (b, bs), cuts) - - | cut_level cuts P (Nd (b, bs)) ((p::ps),p_) = - let val (bs',cuts') = cut_level cuts P (nth p bs) (ps, p_) - in (Nd (b, repl_app bs p bs'), cuts @ cuts') end; - -(*OLD version before WN050219, overwritten below*) -fun cut_tree _ (([],_):pos') = raise PTREE "cut_tree _ ([],_)" - | cut_tree pt (pos as ([p],_)) = - let val (pt', cuts) = cut_level ([]:pos' list) [] pt pos - in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete - then [] else [([],Res)])) end - | cut_tree pt (p,p_) = - let - fun cutfn pt cuts (p,p_) = - let val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_) - val cuts'' = if get_obj g_ostate pt (lev_up p) = Incomplete - then [] else [(lev_up p, Res)] - in if length cuts' > 0 andalso length p > 1 - then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*)) - else (pt',cuts @ cuts') end - val (pt', cuts) = cutfn pt [] (p,p_) - in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete - then [] else [([], Res)])) end; - - -(*########/ inserted from ctreeNEW.sml \#################################**) - -(*.get all positions in a ptree until ([],Res) or ostate=Incomplete -val get_allp = fn : - pos' list -> : accumulated, start with [] - pos -> : the offset for subtrees wrt the root - ptree -> : (sub)tree - pos' : initialization (the last pos' before ...) - -> pos' list : of positions in this (sub) tree (relative to the root) -.*) -(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos'); - val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos'); - length (children pt); - *) -fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt = - (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*) - in if nxt <> ([],Res) - then get_allp (cuts @ [nxt]) (P, nxt) pt - else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list - end) handle PTREE _ => (map (apfst (curry op@ P)) cuts); - - -(*the pts are assumed to be on the same level*) -fun get_allps (cuts: pos' list) (P:pos) [] = cuts - | get_allps cuts P (pt::pts) = - let val below = get_allp [] (P, ([], Frm)) pt - val levfrm = - if is_pblnd pt - then (P, Pbl)::below - else if last_elem P = 1 - then (P, Frm)::below - else (*Trans*) below - val levres = levfrm @ (if null below then [(P, Res)] else []) - in get_allps (cuts @ levres) (lev_on P) pts end; - - -(**.these 2 funs decide on how far cut_tree goes.**) -(*.shall the nodes _after_ the pos to be inserted at be deleted?.*) -fun test_trans (PrfObj{branch = Transitive,...}) = true - | test_trans (PrfObj{branch = NoBranch,...}) = true - | test_trans (PblObj{branch = Transitive,...}) = true - | test_trans (PblObj{branch = NoBranch,...}) = true - | test_trans _ = false; -(*.shall cutting be continued on the higher level(s)? - the Nd regarded will NOT be changed.*) -fun cutlevup (PblObj _) = false (*for tests of LK0502*) - | cutlevup _ = true; -val cutlevup = test_trans;(*WN060727 after summerterm tests.LK0502 withdrawn*) - -(*cut_bottom new sml603..608 -cut the level at the bottom of the pos (used by cappend_...) -and handle the parent in order to avoid extra case for root -fn: ptree -> : the _whole_ ptree for cut_levup - pos * posel -> : the pos after split_last - ptree -> : the parent of the Nd to be cut -return - (ptree * : the updated ptree - pos' list) * : the pos's cut - bool : cutting shall be continued on the higher level(s) -*) -fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), cutlevup b) - | cut_bottom (P:pos, p:posel) (Nd (b, bs)) = - let (*divide level into 3 parts...*) - val keep = take (p - 1, bs) - val pt' as Nd (_,bs') = nth p bs - (*^^^^^_here_ will be 'insert'ed by 'append_..'*) - val (tail, tp) = (takerest (p, bs), - if null (takerest (p, bs)) then 0 else p + 1) - val (children, cuts) = - if test_trans b - then (keep, - (if is_pblnd pt' then [(P @ [p], Pbl)] else []) - @ (get_allp [] (P @ [p], (P, Frm)) pt') - @ (get_allps [] (P @ [p+1]) tail)) - else (keep @ [(*'insert'ed by 'append_..'*)] @ tail, - get_allp [] (P @ [p], (P, Frm)) pt') - val (pt'', cuts) = - if cutlevup b - then (Nd (del_res b, children), - cuts @ (if g_ostate b = Incomplete then [] else [(P,Res)])) - else (Nd (b, children), cuts) - (*val _= writeln("####cut_bottom (P, p)="^pos2str (P @ [p])^ - ", Nd=.............................................") - val _= show_pt pt'' - val _= writeln("####cut_bottom form='"^ - term2str (get_obj g_form pt'' [])) - val _= writeln("####cut_bottom cuts#="^string_of_int (length cuts)^ - ", cuts="^pos's2str cuts)*) - in ((pt'', cuts:pos' list), cutlevup b) end; - - -(*.go all levels from the bottom of 'pos' up to the root, - on each level compose the children of a node and accumulate the cut Nds -args - pos' list -> : for accumulation - bool -> : cutting shall be continued on the higher level(s) - ptree -> : the whole ptree for 'get_nd pt P' on each level - ptree -> : the Nd from the lower level for insertion at path - pos * posel -> : pos=path split for convenience - ptree -> : Nd the children of are under consideration on this call -returns : - ptree * pos' list : the updated parent-Nd and the pos's of the Nds cut -.*) -fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:posel) (Nd (b, bs)) = - let (*divide level into 3 parts...*) - val keep = take (p - 1, bs) - (*val pt' comes as argument from below*) - val (tail, tp) = (takerest (p, bs), - if null (takerest (p, bs)) then 0 else p + 1) - val (children, cuts') = - if clevup - then (keep @ [pt'], get_allps [] (P @ [p+1]) tail) - else (keep @ [pt'] @ tail, []) - val clevup' = if clevup then cutlevup b else false - (*the first Nd with false stops cutting on all levels above*) - val (pt'', cuts') = - if clevup' - then (Nd (del_res b, children), - cuts' @ (if g_ostate b = Incomplete then [] else [(P,Res)])) - else (Nd (b, children), cuts') - (*val _= writeln("#####cut_levup clevup= "^bool2str clevup) - val _= writeln("#####cut_levup cutlevup b= "^bool2str (cutlevup b)) - val _= writeln("#####cut_levup (P, p)="^pos2str (P @ [p])^ - ", Nd=.............................................") - val _= show_pt pt'' - val _= writeln("#####cut_levup form='"^ - term2str (get_obj g_form pt'' [])) - val _= writeln("#####cut_levup cuts#="^string_of_int (length cuts)^ - ", cuts="^pos's2str cuts)*) - in if null P then (pt'', (cuts @ cuts'):pos' list) - else let val (P, p) = split_last P - in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P) - end - end; - -(*.cut nodes after and below an inserted node in the ctree; - the cuts range is limited by the predicate 'fun cutlevup'.*) -fun cut_tree pt (pos,_) = - if not (existpt pos pt) - then (pt,[]) (*appending a formula never cuts anything*) - else let val (P, p) = split_last pos - val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P) - (* pt' is the updated parent of the Nd to cappend_..*) - in if null P then (pt', cuts) - else let val (P, p) = split_last P - in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P) - end - end; - -fun append_atomic p l f r f' s pt = - let (**val _= writeln("#@append_atomic: pos ="^pos2str p)**) - val (iss, f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac - then (*after Take*) - ((fst (get_obj g_loc pt p), SOME l), - get_obj g_form pt p) - else ((NONE, SOME l), f) - in insert (PrfObj {cell = NONE, - form = f, - tac = r, - loc = iss, - branch= NoBranch, - result= f', - ostate= s}) pt p end; - - -(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here: - detail - generate - cappend: inserted, not appended !!! - - cut decided in applicable_in !?! -*) -fun cappend_atomic pt p loc f r f' s = -(* val (pt, p, loc, f, r, f', s) = - (pt,p,l,f,Rewrite_Set_Inst (subst2subs subs',id_rls rls'), - (f',asm),Complete); - *) -((*writeln("##@cappend_atomic: pos ="^pos2str p);*) - apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm)) -); -(*TODO.WN050305 redesign the handling of istates*) -fun cappend_atomic pt p ist_res f r f' s = - if existpt p pt andalso get_obj g_tac pt p=Empty_Tac - then (*after Take: transfer Frm and respective istate*) - let val (ist_form, f) = (get_loc pt (p,Frm), - get_obj g_form pt p) - val (pt, cs) = cut_tree pt (p,Frm) - val pt = append_atomic p e_istate f r f' s pt - val pt = update_loc' pt p (SOME ist_form, SOME ist_res) - in (pt, cs) end - else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm)); - - -(* called by Take *) -fun append_form p l f pt = -((*writeln("##@append_form: pos ="^pos2str p);*) - insert (PrfObj {cell = NONE, - form = (*if existpt p pt - andalso get_obj g_tac pt p = Empty_Tac - (*distinction from 'old' (+complete!) pobjs*) - then get_obj g_form pt p else*) f, - tac = Empty_Tac, - loc = (SOME l, NONE), - branch= NoBranch, - result= (e_term,[]), - ostate= Incomplete}) pt p -); -(* val (p,loc,f) = ([1], e_istate, str2term "x + 1 = 2"); - val (p,loc,f) = (fst p, e_istate, str2term "-1 + x = 0"); - *) -fun cappend_form pt p loc f = -((*writeln("##@cappend_form: pos ="^pos2str p);*) - apfst (append_form p loc f) (cut_tree pt (p,Frm)) -); -fun cappend_form pt p loc f = -let (*val _= writeln("##@cappend_form: pos ="^pos2str p) - val _= writeln("##@cappend_form before cut_tree: loc ="^istate2str loc)*) - val (pt', cs) = cut_tree pt (p,Frm) - val pt'' = append_form p loc f pt' - (*val _= writeln("##@cappend_form after append: loc ="^ - istates2str (get_obj g_loc pt'' p))*) -in (pt'', cs) end; - - - -fun append_result pt p l f s = -((*writeln("##@append_result: pos ="^pos2str p);*) - (appl_obj (repl_result (fst (get_obj g_loc pt p), - SOME l) f s) pt p, []) -); - - -(*WN041022 deprecated, still for kbtest/diffapp.sml, /systest/root-equ.sml*) -fun append_parent p l f r b pt = - let (*val _= writeln("###append_parent: pos ="^pos2str p);*) - val (ll,f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac - then ((fst (get_obj g_loc pt p), SOME l), - get_obj g_form pt p) - else ((SOME l, NONE), f) - in insert (PrfObj - {cell = NONE, - form = f, - tac = r, - loc = ll, - branch= b, - result= (e_term,[]), - ostate= Incomplete}) pt p end; -fun cappend_parent pt p loc f r b = -((*writeln("###cappend_parent: pos ="^pos2str p);*) - apfst (append_parent p loc f r b) (cut_tree pt (p,Und)) -); - - -fun append_problem [] l fmz (strs,spec,hdf) _ = -((*writeln("###append_problem: pos = []");*) - (Nd (PblObj - {cell = NONE, - origin= (strs,spec,hdf), - fmz = fmz, - spec = empty_spec, - probl = []:itm list, - meth = []:itm list, - env = NONE, - loc = (SOME l, NONE), - branch= TransitiveB,(*FIXXXXXME.27.8.03: for equations only*) - result= (e_term,[]), - ostate= Incomplete},[])) -) - | append_problem p l fmz (strs,spec,hdf) pt = -((*writeln("###append_problem: pos ="^pos2str p);*) - insert (PblObj - {cell = NONE, - origin= (strs,spec,hdf), - fmz = fmz, - spec = empty_spec, - probl = []:itm list, - meth = []:itm list, - env = NONE, - loc = (SOME l, NONE), - branch= TransitiveB, - result= (e_term,[]), - ostate= Incomplete}) pt p -); -fun cappend_problem _ [] loc fmz ori = -((*writeln("###cappend_problem: pos = []");*) - (append_problem [] loc fmz ori EmptyPtree,[]) -) - | cappend_problem pt p loc fmz ori = -((*writeln("###cappend_problem: pos ="^pos2str p);*) - apfst (append_problem p (loc:istate) fmz ori) (cut_tree pt (p,Frm)) -); - -(*.get the theory explicitly specified for the rootpbl; - thus use this function _after_ finishing specification.*) -fun rootthy (Nd (PblObj {spec=(thyID, _, _),...}, _)) = assoc_thy thyID - | rootthy _ = raise error "rootthy"; - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/generate.sml --- a/src/Tools/isac/ME/generate.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,586 +0,0 @@ -(* use"ME/generate.sml"; - use"generate.sml"; - *) - -(*.initialize istate for Detail_Set.*) -(* -fun init_istate (Rewrite_Set rls) = -(* val (Rewrite_Set rls) = (get_obj g_tac pt p); - *) - (case assoc_rls rls of - Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t)) -(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls; - *) - | Rls {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Rls {scr=Script s,...} => -(* val Rls {scr=Script s,...} = assoc_rls rls; - *) - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)) - | Seq {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Seq {srls=srls,scr=Script s,...} => - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))) - | init_istate (Rewrite_Set_Inst (subs, rls)) = -(* val (Rewrite_Set_Inst (subs, rls)) = (get_obj g_tac pt p); - *) - let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs - in case assoc_rls rls of - Rls {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Rls {scr=Script s,...} => - let val (a1, a2) = two_scr_arg s - in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end - | Seq {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") -(* val Seq {scr=Script s,...} = assoc_rls rls; - *) - | Seq {scr=Script s,...} => - let val (a1, a2) = two_scr_arg s - in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end - end; -*) -(*~~~~~~~~~~~~~~~~~~~~~~copy for dev. until del.~~~~~~~~~~~~~~~~~~~~~~~~~*) -fun init_istate (Rewrite_Set rls) t = -(* val (Rewrite_Set rls) = (get_obj g_tac pt p); - *) - (case assoc_rls rls of - Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t)) -(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls; - *) - | Rls {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Rls {scr=Script s,...} => -(* val Rls {scr=Script s,...} = assoc_rls rls; - *) - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)) - | Seq {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Seq {srls=srls,scr=Script s,...} => - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))) -(* val ((Rewrite_Set_Inst (subs, rls)), t) = ((get_obj g_tac pt p), t); - *) - | init_istate (Rewrite_Set_Inst (subs, rls)) t = - let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs - (*...we suppose the substitution of only _one_ bound variable*) - in case assoc_rls rls of - Rls {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") - | Rls {scr=Script s,...} => - let val (form, bdv) = two_scr_arg s - in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true)) - end - | Seq {scr=EmptyScr,...} => - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr." - ^"use prep_rls for storing rule-sets !") -(* val Seq {scr=Script s,...} = assoc_rls rls; - *) - | Seq {scr=Script s,...} => - let val (form, bdv) = two_scr_arg s - in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true)) - end - end; - - -(*.a taci holds alle information required to build a node in the calc-tree; - a taci is assumed to be used efficiently such that the calc-tree - resulting from applying a taci need not be stored separately; - see "type calcstate".*) -(*TODO.WN0504 redesign ??? or redesign generate ?? see "fun generate" - TODO.WN0512 ? redesign this _list_: - # only used for [Apply_Method + (Take or Subproblem)], i.e. for initacs - # the latter problem may be resolved automatically if "fun autocalc" is - not any more used for the specify-phase and for changing the phases*) -type taci = - (tac * (*for comparison with input tac*) - tac_ * (*for ptree generation*) - (pos' * (*after applying tac_, for ptree generation*) - istate)); (*after applying tac_, for ptree generation*) -val e_taci = (Empty_Tac, Empty_Tac_, (e_pos', e_istate)): taci; -(* val (tac, tac_, (pos', istate))::_ = tacis'; - *) -fun taci2str ((tac, tac_, (pos', istate)):taci) = - "( "^tac2str tac^", "^tac_2str tac_^", ( "^pos'2str pos' - ^", "^istate2str istate^" ))"; -fun tacis2str tacis = (strs2str o (map (linefeed o taci2str))) tacis; - -datatype pblmet = (*%^%*) - Upblmet (*undefined*) - | Problem of pblID (*%^%*) - | Method of metID; (*%^%*) -fun pblmet2str (Problem pblID) = "Problem "^(strs2str pblID)(*%^%*) - | pblmet2str (Method metID) = "Method "^(metID2str metID);(*%^%*) - (*%^%*) (*26.6. moved to sequent.sml: fun ~~~~~~~~~; was here below*) - - -(* copy from 03.60.usecases.sml 15.11.99 *) -datatype user_cmd = - Accept | NotAccept | Example -| YourTurn | MyTurn (* internal use only 7.6.02 java-sml*) -| Rules -| DontKnow (*| HowComes | WhatFor 7.6.02 java-sml*) -| Undo (*| Back | Forward 7.6.02 java-sml*) -| EndProof | EndSession -| ActivePlus | ActiveMinus | SpeedPlus | SpeedMinus - (*Stepwidth...7.6.02 java-sml*) -| Auto | NotAuto | Details; -(* for test-print-outs *) -fun user_cmd2str Accept ="Accept" - | user_cmd2str NotAccept ="NotAccept" - | user_cmd2str Example ="Example" - | user_cmd2str MyTurn ="MyTurn" - | user_cmd2str YourTurn ="YourTurn" - | user_cmd2str Rules ="Rules" -(*| user_cmd2str HowComes ="HowComes"*) - | user_cmd2str DontKnow ="DontKnow" -(*| user_cmd2str WhatFor ="WhatFor" - | user_cmd2str Back ="Back"*) - | user_cmd2str Undo ="Undo" -(*| user_cmd2str Forward ="Forward"*) - | user_cmd2str EndProof ="EndProof" - | user_cmd2str EndSession ="EndSession" - | user_cmd2str ActivePlus = "ActivePlus" - | user_cmd2str ActiveMinus = "ActiveMinus" - | user_cmd2str SpeedPlus = "SpeedPlus" - | user_cmd2str SpeedMinus = "SpeedMinus" - | user_cmd2str Auto = "Auto" - | user_cmd2str NotAuto = "NotAuto" - | user_cmd2str Details = "Details"; - - - -(*3.5.00: TODO: foppFK eliminated in interface FE-KE !!!*) -datatype foppFK = (* in DG cases div 2 *) - EmptyFoppFK (*DG internal*) -| FormFK of cterm' -| PpcFK of cterm' ppc; -fun foppFK2str (FormFK ct') ="FormFK "^ct' - | foppFK2str (PpcFK ppc) ="PpcFK "^(ppc2str ppc) - | foppFK2str EmptyFoppFK ="EmptyFoppFK"; - - -datatype nest = Open | Closed | Nundef; -fun nest2str Open = "Open" - | nest2str Closed = "Closed" - | nest2str Nundef = "Nundef"; - -type indent = int; -datatype edit = EdUndef | Write | Protect; - (* bridge --> kernel *) - (* bridge <-> kernel *) -(* needed in dialog.sml *) (* bridge <-- kernel *) -fun edit2str EdUndef = "EdUndef" - | edit2str Write = "Write" - | edit2str Protect = "Protect"; - - -datatype inout = - New_User | End_User (*<->*) -| New_Proof | End_Proof (*<->*) -| Command of user_cmd (*-->*) -| Request of string | Message of string (*<--*) -| Error_ of string | System of string (*<--*) -| FoPpcFK of foppFK (*-->*) -| FormKF of cellID * edit * indent * nest * cterm' (*<--*) -| PpcKF of cellID * edit * indent * nest * (pblmet * item ppc) (*<--*) -| RuleFK of tac (*-->*) -| RuleKF of edit * tac (*<--*) -| RefinedKF of (pblID * ((itm list) * ((bool * term) list))) (*<--*) -| Select of tac list (*<--*) -| RefineKF of match list (*<--*) -| Speed of int (*<--*) -| Active of int (*<--*) -| Domain of domID; (*<--*) - -fun inout2str End_Proof = "End_Proof" - | inout2str (Command user_cmd) = "Command "^(user_cmd2str user_cmd) - | inout2str (Request s) = "Request "^s - | inout2str (Message s) = "Message "^s - | inout2str (Error_ s) = "Error_ "^s - | inout2str (System s) = "System "^s - | inout2str (FoPpcFK foppFK) = "FoPpcFK "^(foppFK2str foppFK) - | inout2str (FormKF (cellID, edit, indent, nest, ct')) = - "FormKF ("^(string_of_int cellID)^"," - ^(edit2str edit)^","^(string_of_int indent)^"," - ^(nest2str nest)^",(" - ^ct' ^")" - | inout2str (PpcKF (cellID, edit, indent, nest, (pm,itemppc))) = - "PpcKF ("^(string_of_int cellID)^"," - ^(edit2str edit)^","^(string_of_int indent)^"," - ^(nest2str nest)^",(" - ^(pblmet2str pm)^","^(itemppc2str itemppc)^"))" - | inout2str (RuleKF (edit,tac)) = "RuleKF "^ - pair2str(edit2str edit,tac2str tac) - | inout2str (RuleFK tac) = "RuleFK "^(tac2str tac) - | inout2str (Select tacs)= - "Select "^((strs2str' o (map tac2str)) tacs) - | inout2str (RefineKF ms) = "RefineKF "^(matchs2str ms) - | inout2str (Speed i) = "Speed "^(string_of_int i) - | inout2str (Active i) = "Active "^(string_of_int i) - | inout2str (Domain dI) = "Domain "^dI; -fun inouts2str ios = (strs2str' o (map inout2str)) ios; - -datatype mout = - Form' of inout (* packing cterm' | cterm' ppc *) -| Problems of inout (* passes specify (and solve) *) -| Error' of inout -| EmptyMout; - -fun mout2str (Form' inout) ="Form' "^(inout2str inout) - | mout2str (Error' inout) ="Error' "^(inout2str inout) - | mout2str (EmptyMout ) ="EmptyMout"; - -(*fun Form'2str (Form' )*) - - - - - -(* init pbl with ...,dsc,empty | [] *) -fun init_pbl pbt = - let - fun pbt2itm (f,(d,t)) = - ((0,[],false,f,Inc((d,[]),(e_term,[]))):itm); - in map pbt2itm pbt end; -(*take formal parameters from pbt, for transfer from pbl/met-hierarchy*) -fun init_pbl' pbt = - let - fun pbt2itm (f,(d,t)) = - ((0,[],false,f,Inc((d,[t]),(e_term,[]))):itm); - in map pbt2itm pbt end; - - -(*generate 1 ppobj in ptree*) -(*TODO.WN0501: take calcstate as an argument (see embed_derive etc.)?specify?*) -fun generate1 thy (Add_Given' (_, itmlist)) Uistate (pos as (p,p_)) pt = - (pos:pos',[],Form' (PpcKF (0,EdUndef,0,Nundef, - (Upblmet,itms2itemppc thy [][]))), - case p_ of Pbl => update_pbl pt p itmlist - | Met => update_met pt p itmlist) - | generate1 thy (Add_Find' (_, itmlist)) Uistate (pos as (p,p_)) pt = - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - case p_ of Pbl => update_pbl pt p itmlist - | Met => update_met pt p itmlist) - | generate1 thy (Add_Relation' (_, itmlist)) Uistate (pos as (p,p_)) pt = - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - case p_ of Pbl => update_pbl pt p itmlist - | Met => update_met pt p itmlist) - - | generate1 thy (Specify_Theory' domID) Uistate (pos as (p,_)) pt = - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - update_domID pt p domID) - - | generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate - (pos as (p,_)) pt = - let val pt = update_pbl pt p itms - val pt = update_pblID pt p pI - in ((p,Pbl),[], - Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - pt) end - - | generate1 thy (Specify_Method' (mID, oris, itms)) Uistate - (pos as (p,_)) pt = - let val pt = update_oris pt p oris - val pt = update_met pt p itms - val pt = update_metID pt p mID - in ((p,Met),[], - Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - pt) end - - | generate1 thy (Model_Problem' (_, itms, met)) Uistate (pos as (p,_)) pt = -(* val (itms,pos as (p,_)) = (pbl, pos); - *) - let val pt = update_pbl pt p itms - val pt = update_met pt p met - in (pos,[],Form'(PpcKF(0,EdUndef,0,Nundef, - (Upblmet,itms2itemppc thy [][]))), pt) end - - | generate1 thy (Refine_Tacitly' (pI,pIre,domID,metID,pbl)) - Uistate (pos as (p,_)) pt = - let val pt = update_pbl pt p pbl - val pt = update_orispec pt p (domID,pIre,metID) - in (pos,[], - Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))), - pt) end - - | generate1 thy (Refine_Problem' (pI,_)) Uistate (pos as (p,_)) pt = - let val (dI,_,mI) = get_obj g_spec pt p - val pt = update_spec pt p (dI, pI, mI) - in (pos,[], - Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),pt) - end - - | generate1 thy (Apply_Method' (_,topt, is)) _ (pos as (p,p_)) pt = - ((*writeln("###generate1 Apply_Method': pos = "^pos'2str (p,p_)); - writeln("###generate1 Apply_Method': topt= "^termopt2str topt); - writeln("###generate1 Apply_Method': is = "^istate2str is);*) - case topt of - SOME t => - let val (pt,c) = cappend_form pt p is t - (*val _= writeln("###generate1 Apply_Method: after cappend")*) - in (pos,c, EmptyMout,pt) - end - | NONE => - (pos,[],EmptyMout,update_env pt p (SOME is))) -(* val (thy, (Take' t), l, (p,p_), pt) = - ((assoc_thy "Isac.thy"), tac_, is, pos, pt); - *) - | generate1 thy (Take' t) l (p,p_) pt = (* val (Take' t) = m; *) - let (*val _=writeln("### generate1: Take' pos="^pos'2str (p,p_));*) - val p = let val (ps,p') = split_last p(*no connex to prev.ppobj*) - in if p'=0 then ps@[1] else p end; - val (pt,c) = cappend_form pt p l t; - in ((p,Frm):pos', c, - Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), pt) end - -(* val (l, (p,p_)) = (RrlsState is, p); - - val (thy, Begin_Trans' t, l, (p,Frm), pt) = - (assoc_thy "Isac.thy", tac_, is, p, pt); - *) - | generate1 thy (Begin_Trans' t) l (p,Frm) pt = - let (* print_depth 99; - map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3; - *) - val (pt,c) = cappend_form pt p l t - (* print_depth 99; - map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3; - *) - val pt = update_branch pt p TransitiveB (*040312*) - (*replace the old PrfOjb ~~~~~*) - val p = (lev_on o lev_dn(*starts with [...,0]*)) p; - val (pt,c') = cappend_form pt p l t(*FIXME.0402 same istate ???*); - in ((p,Frm), c @ c', Form' (FormKF (~1,EdUndef,(length p), Nundef, - term2str t)), pt) end - - (* val (thy, Begin_Trans' t, l, (p,Res), pt) = - (assoc_thy "Isac.thy", tac_, is, p, pt); - *) - | generate1 thy (Begin_Trans' t) l (p ,Res) pt = - (*append after existing PrfObj _________*) - generate1 thy (Begin_Trans' t) l (lev_on p,Frm) pt - - | generate1 thy (End_Trans' tasm) l (p,p_) pt = - let val p' = lev_up p - val (pt,c) = append_result pt p' l tasm Complete; - in ((p',Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), - pt) end - - | generate1 thy (Rewrite_Inst' (_,_,_,_,subs',thm',f,(f',asm))) l (p,p_) pt = - let (*val _= writeln("###generate1 Rewrite_Inst': pos= "^pos'2str (p,p_));*) - val (pt,c) = cappend_atomic pt p l f - (Rewrite_Inst (subst2subs subs',thm')) (f',asm) Complete; - val pt = update_branch pt p TransitiveB (*040312*) - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*) - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt) end - - | generate1 thy (Rewrite' (thy',ord',rls',pa,thm',f,(f',asm))) l (p,p_) pt = - let (*val _= writeln("###generate1 Rewrite': pos= "^pos'2str (p,p_))*) - val (pt,c) = cappend_atomic pt p l f (Rewrite thm') (f',asm) Complete - val pt = update_branch pt p TransitiveB (*040312*) - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*) - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt)end - - | generate1 thy (Rewrite_Asm' all) l p pt = - generate1 thy (Rewrite' all) l p pt - - | generate1 thy (Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm))) l (p,p_) pt = -(* val (thy, Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm)), l, (p,p_), pt) = - (assoc_thy "Isac.thy", tac_, is, pos, pt); - *) - let (*val _=writeln("###generate1 Rewrite_Set_Inst': pos= "^pos'2str(p,p_))*) - val (pt,c) = cappend_atomic pt p l f - (Rewrite_Set_Inst (subst2subs subs',id_rls rls')) (f',asm) Complete - val pt = update_branch pt p TransitiveB (*040312*) - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*) - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt) end - - | generate1 thy (Detail_Set_Inst' (_,_,subs,rls,f,(f',asm))) l (p,p_) pt = - let val (pt,c) = cappend_form pt p l f - val pt = update_branch pt p TransitiveB (*040312*) - - val is = init_istate (Rewrite_Set_Inst (subst2subs subs, id_rls rls)) f - val tac_ = Apply_Method' (e_metID, SOME t, is) - val pos' = ((lev_on o lev_dn) p, Frm) - in (*implicit Take*) generate1 thy tac_ is pos' pt end - - | generate1 thy (Rewrite_Set' (_,_,rls',f,(f',asm))) l (p,p_) pt = - let (*val _= writeln("###generate1 Rewrite_Set': pos= "^pos'2str (p,p_))*) - val (pt,c) = cappend_atomic pt p l f - (Rewrite_Set (id_rls rls')) (f',asm) Complete - val pt = update_branch pt p TransitiveB (*040312*) - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*) - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt) end - - | generate1 thy (Detail_Set' (_,_,rls,f,(f',asm))) l (p,p_) pt = - let val (pt,c) = cappend_form pt p l f - val pt = update_branch pt p TransitiveB (*040312*) - - val is = init_istate (Rewrite_Set (id_rls rls)) f - val tac_ = Apply_Method' (e_metID, SOME t, is) - val pos' = ((lev_on o lev_dn) p, Frm) - in (*implicit Take*) generate1 thy tac_ is pos' pt end - - | generate1 thy (Check_Postcond' (pI,(scval,asm))) l (p,p_) pt = - let (*val _=writeln("###generate1 Check_Postcond': pos= "^pos'2str(p,p_))*) - (*val (l',_) = get_obj g_loc pt p..don't overwrite with l from subpbl*) - val (pt,c) = append_result pt p l (scval,map str2term asm) Complete - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), - Nundef, term2str scval)), pt) end - - | generate1 thy (Calculate' (thy',op_,f,(f',thm'))) l (p,p_) pt = - let val (pt,c) = cappend_atomic pt p l f (Calculate op_) (f',[]) Complete; - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt) end - - | generate1 thy (Check_elementwise' (consts,pred,(f',asm))) l (p,p_) pt = - let(*val _=writeln("###generate1 Check_elementwise': p= "^pos'2str(p,p_))*) - val (pt,c) = cappend_atomic pt p l consts - (Check_elementwise pred) (f',asm) Complete; - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')), - pt) end - - | generate1 thy (Or_to_List' (ors,list)) l (p,p_) pt = - let val (pt,c) = cappend_atomic pt p l ors - Or_to_List (list,[]) Complete; - in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, term2str list)), - pt) end - - | generate1 thy (Substitute' (subte, t, t')) l (p,p_) pt = - let val (pt,c) = cappend_atomic pt p l t (Substitute (subte2sube subte)) - (t',[]) Complete; - in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, - term2str t')), pt) - end - - | generate1 thy (Tac_ (_,f,id,f')) l (p,p_) pt = - let val (pt,c) = cappend_atomic pt p l (str2term f) - (Tac id) (str2term f',[]) Complete; - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f')), pt)end - - | generate1 thy (Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, f)) - l (p,p_) pt = - let (*val _=writeln("###generate1 Subproblem': pos= "^pos'2str (p,p_))*) - val (pt,c) = cappend_problem pt p l (fmz_, (domID, pblID, metID)) - (oris, (domID, pblID, metID), hdl); - (*val pbl = init_pbl ((#ppc o get_pbt) pblID); - val pt = update_pblppc pt p pbl;--------4.9.03->Model_Problem*) - (*val _= writeln("### generate1: is([3],Frm)= "^ - (istate2str (get_istate pt ([3],Frm))));*) - val f = Syntax.string_of_term (thy2ctxt thy) f; - in ((p,Pbl), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f)), pt) end - - | generate1 thy m' _ _ _ = - raise error ("generate1: not impl.for "^(tac_2str m')) -; - - -fun generate_hard thy m' (p,p_) pt = - let - val p = case p_ of Frm => p | Res => lev_on p - | _ => raise error ("generate_hard: call by "^(pos'2str (p,p_))); - in generate1 thy m' e_istate (p,p_) pt end; - - - -(*tacis are in reverse order from nxt_solve_/specify_: last = fst to insert*) -(* val (tacis, (pt, _)) = (tacis, ptp); - - val (tacis, (pt, c, _)) = (rev tacis, (pt, [], (p, Res))); - *) -fun generate ([]: taci list) ptp = ptp - | generate tacis (pt, c, _:pos'(*!dropped!WN0504redesign generate/tacis?*))= - let val (tacis', (_, tac_, (p, is))) = split_last tacis - (* for recursion ... - (tacis', (_, tac_, (p, is))) = split_last tacis'; - *) - val (p',c',_,pt') = generate1 (assoc_thy "Isac.thy") tac_ is p pt - in generate tacis' (pt', c@c', p') end; - - - -(*. a '_deriv'ation is constructed during 'reverse rewring' by an Rrls * - * of for connecting a user-input formula with the current calc-state. * - *# It is somewhat incompatible with the rest of the math-engine: * - * (1) it is not created by a script * - * (2) thus there cannot be another user-input within a derivation * - *# It suffers particularily from the not-well-foundedness of the math-engine* - * (1) FIXME other branchtyptes than Transitive will change 'embed_deriv' * - * (2) FIXME and eventually 'compare_step' (ie. the script interpreter) * - * (3) FIXME and eventually 'lev_back' * - *# SOME improvements are evident FIXME.040215 '_deriv'ation: * - * (1) FIXME nest Rls_ in 'make_deriv' * - * (2) FIXME do the not-reversed part in 'make_deriv' by scripts -- thus * - * user-input will become possible in this part of a derivation * - * (3) FIXME do (2) only if a derivation has been found -- for efficiency, * - * while a non-derivable inform requires to step until End_Proof' * - * (4) FIXME find criteria on when _not_ to step until End_Proof' * - * (5) FIXME -.*) -(*.update pos in tacis for embedding by generate.*) -(* val - *) -fun insert_pos _ [] = [] - | insert_pos (p:pos) (((tac,tac_,(_, ist))::tacis):taci list) = - ((tac,tac_,((p, Res), ist)):taci) - ::((insert_pos (lev_on p) tacis):taci list); - -fun res_from_taci (_, Rewrite'(_,_,_,_,_,_,(res, asm)), _) = (res, asm) - | res_from_taci (_, Rewrite_Set'(_,_,_,_,(res, asm)), _) = (res, asm) - | res_from_taci (_, tac_, _) = - raise error ("res_from_taci: called with" ^ tac_2str tac_); - -(*.embed the tacis created by a '_deriv'ation; sys.form <> input.form - tacis are in order, thus are reverted for generate.*) -(* val (tacis, (pt, pos as (p, Frm))) = (tacis', ptp); - *) -fun embed_deriv (tacis:taci list) (pt, pos as (p, Frm):pos') = - (*inform at Frm: replace the whole PrfObj by a Transitive-ProfObj FIXME?0402 - and transfer the istate (from _after_ compare_deriv) from Frm to Res*) - let val (res, asm) = (res_from_taci o last_elem) tacis - val (SOME ist,_) = get_obj g_loc pt p - val form = get_obj g_form pt p - (*val p = lev_on p; ---------------only difference to (..,Res) below*) - val tacis = (Begin_Trans, Begin_Trans' form, (pos, Uistate)) - ::(insert_pos ((lev_on o lev_dn) p) tacis) - @ [(End_Trans, End_Trans' (res, asm), - (pos_plus (length tacis) (lev_dn p, Res), - new_val res ist))] - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) - val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res)) - val pt = update_tac pt p (Derive (id_rls nrls)) - (*FIXME.040216 struct.ctree*) - val pt = update_branch pt p TransitiveB - in (c, (pt, pos:pos')) end - -(* val (tacis, (pt, (p, Res))) = (tacis', ptp); - *) - | embed_deriv tacis (pt, (p, Res)) = - (*inform at Res: append a Transitive-PrfObj FIXME?0402 other branch-types ? - and transfer the istate (from _after_ compare_deriv) from Res to new Res*) - let val (res, asm) = (res_from_taci o last_elem) tacis - val (_, SOME ist) = get_obj g_loc pt p - val (f,a) = get_obj g_result pt p - val p = lev_on p(*---------------only difference to (..,Frm) above*); - val tacis = (Begin_Trans, Begin_Trans' f, ((p, Frm), Uistate)) - ::(insert_pos ((lev_on o lev_dn) p) tacis) - @ [(End_Trans, End_Trans' (res, asm), - (pos_plus (length tacis) (lev_dn p, Res), - new_val res ist))]; - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) - val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res)) - val pt = update_tac pt p (Derive (id_rls nrls)) - (*FIXME.040216 struct.ctree*) - val pt = update_branch pt p TransitiveB - in (c, (pt, pos)) end; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/inform.sml --- a/src/Tools/isac/ME/inform.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,734 +0,0 @@ -(* Handle user-input during the specify- and the solve-phase. - author: Walther Neuper - 0603 - (c) due to copyright terms - -use"ME/inform.sml"; -use"inform.sml"; -*) - -signature INFORM = - sig - - type castab - type icalhd - - (* type iitem *) - datatype - iitem = - Find of cterm' list - | Given of cterm' list - | Relate of cterm' list - type imodel - val imodel2fstr : iitem list -> (string * cterm') list - - - val Isac : 'a -> theory - val appl_add' : - theory' -> - SpecifyTools.ori list -> - SpecifyTools.itm list -> - ('a * (Term.term * Term.term)) list -> - string * cterm' -> SpecifyTools.itm - (* val appl_adds : - theory' -> - SpecifyTools.ori list -> - SpecifyTools.itm list -> - (string * (Term.term * Term.term)) list -> - (string * string) list -> SpecifyTools.itm list *) - (* val cas_input : string -> ptree * ocalhd *) - (* val cas_input_ : - spec -> - (Term.term * Term.term list) list -> - pblID * SpecifyTools.itm list * metID * SpecifyTools.itm list * - (bool * Term.term) list *) - val castab : castab ref - val compare_step : - calcstate' -> Term.term -> string * calcstate' - (* val concat_deriv : - 'a * ((Term.term * Term.term) list -> Term.term * Term.term -> bool) - -> - rls -> - rule list -> - Term.term -> - Term.term -> - bool * (Term.term * rule * (Term.term * Term.term list)) list *) - val dropwhile' : (* systest/auto-inform.sml *) - ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list - (* val dtss2itm_ : - pbt_ list -> - Term.term * Term.term list -> - int list * bool * string * SpecifyTools.itm_ *) - (* val e_icalhd : icalhd *) - val eq7 : ''a * ''b -> ''a * (''b * 'c) -> bool - val equal : ''a -> ''a -> bool - (* val filter_dsc : - SpecifyTools.ori list -> SpecifyTools.itm -> SpecifyTools.ori list *) - (* val filter_sep : ('a -> bool) -> 'a list -> 'a list * 'a list *) - (* val flattup2 : 'a * ('b * 'c * 'd * 'e) -> 'a * 'b * 'c * 'd * 'e *) - (* val fstr2itm_ : - theory -> - (''a * (Term.term * Term.term)) list -> - ''a * string -> int list * bool * ''a * SpecifyTools.itm_ *) - val inform : - calcstate' -> cterm' -> string * calcstate' - val input_icalhd : ptree -> icalhd -> ptree * ocalhd - (* val is_Par : SpecifyTools.itm -> bool *) - (* val is_casinput : cterm' -> fmz -> bool *) - (* val is_e_ts : Term.term list -> bool *) - (* val itms2fstr : SpecifyTools.itm -> string * string *) - (* val mk_tacis : - rew_ord' * 'a -> - rls -> - Term.term * rule * (Term.term * Term.term list) -> - tac * tac_ * (pos' * istate) *) - val oris2itms : - 'a -> int -> SpecifyTools.ori list -> SpecifyTools.itm list - (* val par2fstr : SpecifyTools.itm -> string * cterm' *) - (* val parsitm : theory -> SpecifyTools.itm -> SpecifyTools.itm *) - val rev_deriv' : 'a * rule * ('b * 'c) -> 'b * rule * ('a * 'c) - (* val unknown_expl : - theory' -> - (string * (Term.term * Term.term)) list -> - (string * string) list -> SpecifyTools.itm list *) - end - - - - - - -(***. handle an input calc-head .***) - -(*------------------------------------------------------------------(**) -structure inform :INFORM = -struct -(**)------------------------------------------------------------------*) - -datatype iitem = - Given of cterm' list -(*Where is never input*) -| Find of cterm' list -| Relate of cterm' list; - -type imodel = iitem list; - -(*calc-head as input*) -type icalhd = - pos' * (*the position of the calc-head in the calc-tree - pos' as (p,p_) where p_ is neglected due to pos_ below*) - cterm' * (*the headline*) - imodel * (*the model (without Find) of the calc-head*) - pos_ * (*model belongs to Pbl or Met*) - spec; (*specification: domID, pblID, metID*) -val e_icalhd = (e_pos', "", [Given [""]], Pbl, e_spec): icalhd; - -fun is_casinput (hdf: cterm') ((fmz_, spec): fmz) = - hdf <> "" andalso fmz_ = [] andalso spec = e_spec; - -(*.handle an input as into an algebra system.*) -fun dtss2itm_ ppc (d, ts) = - let val (f, (d, id)) = the (find_first ((curry op= d) o - (#1: (term * term) -> term) o - (#2: pbt_ -> (term * term))) ppc) - in ([1], true, f, Cor ((d, ts), (id, ts))) end; - -fun flattup2 (a,(b,c,d,e)) = (a,b,c,d,e); - - - -(*.association list with cas-commands, for generating a complete calc-head.*) -type castab = - (term * (*cas-command, eg. 'solve'*) - (spec * (*theory, problem, method*) - - (*the function generating a kind of formalization*) - (term list -> (*the arguments of the cas-command, eg. (x+1=2, x)*) - (term * (*description of an element*) - term list) (*value of the element (always put into a list)*) - list))) (*of elements in the formalization*) - list; (*of cas-entries in the association list*) - -val castab = ref ([]: castab); - - -(*..*) -(* val (dI,pI,mI) = spec; - *) -(*fun cas_input_ ((dI,pI,mI): spec) dtss = - let val thy = assoc_thy dI - val {ppc,...} = get_pbt pI - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) - val its = add_id its_ - val pits = map flattup2 its - val (pI, mI) = if mI <> ["no_met"] then (pI, mI) - else let val SOME (pI,_) = refine_pbl thy pI pits - in (pI, (hd o #met o get_pbt) pI) end - val {ppc,pre,prls,...} = get_met mI - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) - val its = add_id its_ - val mits = map flattup2 its - val pre = check_preconds thy prls pre mits -in (pI, pits: itm list, mI, mits: itm list, pre) end;*) - -(* val (dI,pI,mI) = spec; - *) -fun cas_input_ ((dI,pI,mI): spec) dtss = - let val thy = assoc_thy dI - val {ppc,...} = get_pbt pI - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) - val its = add_id its_ - val pits = map flattup2 its - val (pI, mI) = if mI <> ["no_met"] then (pI, mI) - else case refine_pbl thy pI pits of - SOME (pI,_) => (pI, (hd o #met o get_pbt) pI) - | NONE => (pI, (hd o #met o get_pbt) pI) - val {ppc,pre,prls,...} = get_met mI - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*) - val its = add_id its_ - val mits = map flattup2 its - val pre = check_preconds thy prls pre mits -in (pI, pits: itm list, mI, mits: itm list, pre) end; - - -(*.check if the input term is a CAScmd and return a ptree with - a _complete_ calchead.*) -(* val hdt = ifo; - *) -fun cas_input hdt = - let val (h,argl) = strip_comb hdt - in case assoc (!castab, h) of - NONE => NONE - (*let val (pt,_) = - cappend_problem e_ptree [] e_istate - ([], e_spec) ([], e_spec, e_term) - in (pt, (false, Pbl, e_term(*FIXXME031:'not found'*), - [], [], e_spec)) end*) - | SOME (spec as (dI,_,_), argl2dtss) => - (* val SOME (spec as (dI,_,_), argl2dtss ) = assoc (!castab, h); - *) - let val dtss = argl2dtss argl - val (pI, pits, mI, mits, pre) = cas_input_ spec dtss - val spec = (dI, pI, mI) - val (pt,_) = - cappend_problem e_ptree [] e_istate ([], e_spec) - ([], e_spec, hdt) - val pt = update_spec pt [] spec - val pt = update_pbl pt [] pits - val pt = update_met pt [] mits - in SOME (pt, (true, Met, hdt, mits, pre, spec):ocalhd) end - end; - -(*lazy evaluation for Isac.thy*) -fun Isac _ = assoc_thy "Isac.thy"; - -(*re-parse itms with a new thy and prepare for checking with ori list*) -fun parsitm dI (itm as (i,v,b,f, Cor ((d,ts),_)):itm) = -(* val itm as (i,v,b,f, Cor ((d,ts),_)) = hd probl; - *) - (let val t = (comp_dts (Isac "delay")) (d,ts); - val s = Syntax.string_of_term (thy2ctxt dI) t; - (*this ^ should raise the exn on unability of re-parsing dts*) - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) - | parsitm dI (itm as (i,v,b,f, Syn str)) = - (let val t = (term_of o the o (parse dI)) str - in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str)) - | parsitm dI (itm as (i,v,b,f, Typ str)) = - (let val t = (term_of o the o (parse dI)) str - in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str)) - | parsitm dI (itm as (i,v,_,f, Inc ((d,ts),_))) = - (let val t = (comp_dts (Isac "delay")) (d,ts); - val s = Syntax.string_of_term (thy2ctxt dI) t; - (*this ^ should raise the exn on unability of re-parsing dts*) - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) - | parsitm dI (itm as (i,v,_,f, Sup (d,ts))) = - (let val t = (comp_dts (Isac"delay" )) (d,ts); - val s = Syntax.string_of_term (thy2ctxt dI) t; - (*this ^ should raise the exn on unability of re-parsing dts*) - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) - | parsitm dI (itm as (i,v,_,f, Mis (d,t'))) = - (let val t = d $ t'; - val s = Syntax.string_of_term (thy2ctxt dI) t; - (*this ^ should raise the exn on unability of re-parsing dts*) - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm)) - | parsitm dI (itm as (i,v,_,f, Par _)) = - raise error ("parsitm (" ^ itm2str_ (thy2ctxt dI) itm^ - "): Par should be internal"); - -(*separate a list to a pair of elements that do NOT satisfy the predicate, - and of elements that satisfy the predicate, i.e. (false, true)*) -fun filter_sep pred xs = - let fun filt ab [] = ab - | filt (a,b) (x :: xs) = if pred x - then filt (a,b@[x]) xs - else filt (a@[x],b) xs - in filt ([],[]) xs end; -fun is_Par ((_,_,_,_,Par _):itm) = true - | is_Par _ = false; - -fun is_e_ts [] = true - | is_e_ts [Const ("List.list.Nil", _)] = true - | is_e_ts _ = false; - -(*WN.9.11.03 copied from fun appl_add (in modspec.sml)*) -(* val (sel,ct) = selct; - val (dI, oris, ppc, pbt, (sel, ct))= - (#1 (some_spec ospec spec), oris, []:itm list, - ((#ppc o get_pbt) (#2 (some_spec ospec spec))), - hd (imodel2fstr imodel)); - *) -fun appl_add' dI oris ppc pbt (sel, ct) = - let - val thy = assoc_thy dI; - in case parse thy ct of - NONE => (0,[],false,sel, Syn ct):itm - | SOME ct => (* val SOME ct = parse thy ct; - *) - (case is_known thy sel oris (term_of ct) of - (* val ("",ori'(*ts='ct'*), all) = is_known thy sel oris (term_of ct); - *) - ("",ori'(*ts='ct'*), all) => - (case is_notyet_input thy ppc all ori' pbt of - (* val ("",itm) = is_notyet_input thy ppc all ori' pbt; - *) - ("",itm) => itm - (* val (msg,xx) = is_notyet_input thy ppc all ori' pbt; - *) - | (msg,_) => raise error ("appl_add': "^msg)) - (* val (msg,(_,_,_,d,ts),all) = is_known thy sel oris (term_of ct); - *) - | (msg,(i,v,_,d,ts),_) => - if is_e_ts ts then (i,v,false, sel, Inc ((d,ts),(e_term,[]))) - else (i,v,false,sel, Sup (d,ts))) - end; - -(*.generate preliminary itm_ from a strin (with field "#Given" etc.).*) -(* val (f, str) = hd selcts; - *) -fun eq7 (f, d) (f', (d', _)) = f=f' andalso d=d'; -fun fstr2itm_ thy pbt (f, str) = - let val topt = parse thy str - in case topt of - NONE => ([], false, f, Syn str) - | SOME ct => -(* val SOME ct = parse thy str; - *) - let val (d,ts) = ((split_dts thy) o term_of) ct - val popt = find_first (eq7 (f,d)) pbt - in case popt of - NONE => ([1](*??*), true(*??*), f, Sup (d,ts)) - | SOME (f, (d, id)) => ([1], true, f, Cor ((d,ts), (id, ts))) - end - end; - - -(*.input into empty PblObj, i.e. empty fmz+origin (unknown example).*) -fun unknown_expl dI pbt selcts = - let - val thy = assoc_thy dI - val its_ = map (fstr2itm_ thy pbt) selcts (*([1],true,"#Given",Cor (...))*) - val its = add_id its_ -in (map flattup2 its): itm list end; - - - - -(*WN.11.03 for input_icalhd, ~ specify_additem for Add_Given/_Find/_Relation - appl_add': generate 1 item - appl_add' . is_known: parse, get data from oris (vats, all (elems if list)..) - appl_add' . is_notyet_input: compare with items in model already input - insert_ppc': insert this 1 item*) -(* val (dI,oris,ppc,pbt,selcts) =((#1 (some_spec ospec spec)),oris,[(*!!*)], - ((#ppc o get_pbt) (#2 (some_spec ospec spec))), - (imodel2fstr imodel)); - *) -fun appl_adds dI [] _ pbt selcts = unknown_expl dI pbt selcts - (*already present itms in model are being overwritten*) - | appl_adds dI oris ppc pbt [] = ppc - | appl_adds dI oris ppc pbt (selct::ss) = - (* val selct = (sel, string_of_cterm ct); - *) - let val itm = appl_add' dI oris ppc pbt selct; - in appl_adds dI oris (insert_ppc' itm ppc) pbt ss end; -(* val (dI, oris, ppc, pbt, selct::ss) = - (dI, pors, probl, ppc, map itms2fstr probl); - ...vvv - *) -(* val (dI, oris, ppc, pbt, (selct::ss))= - (#1 (some_spec ospec spec), oris, []:itm list, - ((#ppc o get_pbt) (#2 (some_spec ospec spec))),(imodel2fstr imodel)); - val iii = appl_adds dI oris ppc pbt (selct::ss); - writeln(itms2str_ thy iii); - - val itm = appl_add' dI oris ppc pbt selct; - val ppc = insert_ppc' itm ppc; - - val _::selct::ss = (selct::ss); - val itm = appl_add' dI oris ppc pbt selct; - val ppc = insert_ppc' itm ppc; - - val _::selct::ss = (selct::ss); - val itm = appl_add' dI oris ppc pbt selct; - val ppc = insert_ppc' itm ppc; - writeln(itms2str_ thy ppc); - - val _::selct::ss = (selct::ss); - val itm = appl_add' dI oris ppc pbt selct; - val ppc = insert_ppc' itm ppc; - *) - - -fun oris2itms _ _ ([]:ori list) = ([]:itm list) - | oris2itms pbt vat ((i,v,f,d,ts)::(os: ori list)) = - if member op = vat v - then (i,v,true,f,Cor ((d,ts),(e_term,[])))::(oris2itms pbt vat os) - else oris2itms pbt vat os; - -fun filter_dsc oris itm = - filter_out ((curry op= ((d_in o #5) (itm:itm))) o - (#4:ori -> term)) oris; - - - - -fun par2fstr ((_,_,_,f, Par s):itm) = (f, s) - | par2fstr itm = raise error ("par2fstr: called with " ^ - itm2str_ (thy2ctxt' "Isac") itm); -fun itms2fstr ((_,_,_,f, Cor ((d,ts),_)):itm) = (f, comp_dts'' (d,ts)) - | itms2fstr (_,_,_,f, Syn str) = (f, str) - | itms2fstr (_,_,_,f, Typ str) = (f, str) - | itms2fstr (_,_,_,f, Inc ((d,ts),_)) = (f, comp_dts'' (d,ts)) - | itms2fstr (_,_,_,f, Sup (d,ts)) = (f, comp_dts'' (d,ts)) - | itms2fstr (_,_,_,f, Mis (d,t)) = (f, term2str (d $ t)) - | itms2fstr (itm as (_,_,_,f, Par _)) = - raise error ("parsitm ("^itm2str_ (thy2ctxt' "Isac") itm ^ - "): Par should be internal"); - -fun imodel2fstr iitems = - let fun xxx is [] = is - | xxx is ((Given strs)::iis) = - xxx (is @ (map (pair "#Given") strs)) iis - | xxx is ((Find strs)::iis) = - xxx (is @ (map (pair "#Find") strs)) iis - | xxx is ((Relate strs)::iis) = - xxx (is @ (map (pair "#Relate") strs)) iis - in xxx [] iitems end; - -(*.input a CAS-command via a whole calchead; - dWN0602 ropped due to change of design in the front-end.*) -(*since previous calc-head _only_ has changed: - EITHER _1_ part of the specification OR some items in the model; - the hdform is left as is except in cas_input .*) -(*FIXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX___Met___XXXXXXXXXXXME.TODO.WN:11.03*) -(* val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = - (p, "xxx", empty_model, Pbl, e_spec); - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = - (p,"", [Given ["fixedValues [r=Arbfix]"], - Find ["maximum A", "valuesFor [a,b]"], - Relate ["relations [A=a*b, a/2=r*sin alpha, \ - \b/2=r*cos alpha]"]], Pbl, e_spec); - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = - (([],Pbl), "not used here", - [Given ["fixedValues [r=Arbfix]"], - Find ["maximum A", "valuesFor [a,b]"(*new input*)], - Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl, - ("DiffApp.thy", ["e_pblID"], ["e_metID"])); - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = ichd; - *) -fun input_icalhd pt (((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)):icalhd) = - let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'), - spec = sspec as (sdI,spI,smI), probl, meth,...} = - get_obj I pt p; - in if is_casinput hdf fmz then the (cas_input (str2term hdf)) - else (*hacked WN0602 ~~~ ~~~~~~~~~, ..dropped !*) - let val (pos_, pits, mits) = - if dI <> sdI - then let val its = map (parsitm (assoc_thy dI)) probl; - val (its, trms) = filter_sep is_Par its; - val pbt = (#ppc o get_pbt) (#2(some_spec ospec sspec)); - in (Pbl, appl_adds dI oris its pbt - (map par2fstr trms), meth) end else - if pI <> spI - then if pI = snd3 ospec then (Pbl, probl, meth) else - let val pbt = (#ppc o get_pbt) pI - val dI' = #1 (some_spec ospec spec) - val oris = if pI = #2 ospec then oris - else prep_ori fmz_(assoc_thy"Isac.thy") pbt; - in (Pbl, appl_adds dI' oris probl pbt - (map itms2fstr probl), meth) end else - if mI <> smI (*FIXME.WN0311: what if probl is incomplete?!*) - then let val met = (#ppc o get_met) mI - val mits = complete_metitms oris probl meth met - in if foldl and_ (true, map #3 mits) - then (Pbl, probl, mits) else (Met, probl, mits) - end else - (Pbl, appl_adds (#1 (some_spec ospec spec)) oris [(*!!!*)] - ((#ppc o get_pbt) (#2 (some_spec ospec spec))) - (imodel2fstr imodel), meth); - val pt = update_spec pt p spec; - in if pos_ = Pbl - then let val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec)) - val pre =check_preconds(assoc_thy"Isac.thy")prls where_ pits - in (update_pbl pt p pits, - (ocalhd_complete pits pre spec, - Pbl, hdf', pits, pre, spec):ocalhd) end - else let val {prls,pre,...} = get_met (#3 (some_spec ospec spec)) - val pre = check_preconds (assoc_thy"Isac.thy") prls pre mits - in (update_met pt p mits, - (ocalhd_complete mits pre spec, - Met, hdf', mits, pre, spec):ocalhd) end - end end - | input_icalhd pt ((p,_), hdf, imodel, _(*Met*), spec as (dI,pI,mI)) = - raise error "input_icalhd Met not impl."; - - -(***. handle an input formula .***) -(* -Untersuchung zur Formeleingabe (appendFormula, replaceFormla) zu einer Anregung von Alan Krempler: -Welche RICHTIGEN Formeln koennen NICHT abgeleitet werden, -wenn Abteilungen nur auf gleichem Level gesucht werden ? -WN.040216 - -Beispiele zum Equationsolver von Richard Lang aus /src/sml/kbtest/rlang.sml - ------------------------------------------------------------------------------- -"Schalk I s.87 Bsp 52a ((5*x)/(x - 2) - x/(x+2)=4)"; ------------------------------------------------------------------------------- -1. "5 * x / (x - 2) - x / (x + 2) = 4" -... -4. "12 * x + 4 * x ^^^ 2 = 4 * (-4 + x ^^^ 2)",Subproblem["normalize", "poly".. -... -4.3. "16 + 12 * x = 0", Subproblem["degree_1", "polynomial", "univariate".. -... -4.3.3. "[x = -4 / 3]")), Check_elementwise "Assumptions" -... -"[x = -4 / 3]" ------------------------------------------------------------------------------- -(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n] - -(4.1)..(4.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n] ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- -"Schalk I s.87 Bsp 55b (x/(x^^^2 - 6*x+9) - 1/(x^^^2 - 3*x) =1/x)"; ------------------------------------------------------------------------------- -1. "x / (x ^^^ 2 - 6 * x + 9) - 1 / (x ^^^ 2 - 3 * x) = 1 / x" -... -4. "(3 + (-1 * x + x ^^^ 2)) * x = 1 * (9 * x + (x ^^^ 3 + -6 * x ^^^ 2))" - Subproblem["normalize", "polynomial", "univariate".. -... -4.4. "-6 * x + 5 * x ^^^ 2 = 0", Subproblem["bdv_only", "degree_2", "poly".. -... -4.4.4. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions" -4.4.5. "[x = 0, x = 6 / 5]" -... -5. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions" - "[x = 6 / 5]" ------------------------------------------------------------------------------- -(1)..(4): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite schiebt [Ableitung waere in 4.4.x] - -(4.1)..(4.4.5): keine 'richtige' Eingabe kann abgeleitet werden, die dem Ergebnis "[x = 6 / 5]" aequivalent ist [Ableitung waere in 5.] ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- -"Schalk II s.56 Bsp 73b (sqrt(x+1)+sqrt(4*x+4)=sqrt(9*x+9))"; ------------------------------------------------------------------------------- -1. "sqrt (x + 1) + sqrt (4 * x + 4) = sqrt (9 * x + 9)" -... -6. "13 + 13 * x + -2 * sqrt ((4 + 4 * x) * (9 + 9 * x)) = 1 + x" - Subproblem["sq", "root", "univariate", "equation"] -... -6.6. "144 + 288 * x + 144 * x ^^^ 2 = 144 + x ^^^ 2 + 288 * x + 143 * x ^^^ 2" - Subproblem["normalize", "polynomial", "univariate", "equation"] -... -6.6.3 "0 = 0" Subproblem["degree_0", "polynomial", "univariate", "equation"] -... Or_to_List -6.6.3.2 "UniversalList" ------------------------------------------------------------------------------- -(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die eine der Wurzeln auf die andere Seite verschieb [Ableitung ware in 6.6.n] - -(6.1)..(6.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 6.6.n] ------------------------------------------------------------------------------- -*) -(*sh. comments auf 498*) - -fun equal a b = a=b; - -(*the lists contain eq-al elem-pairs at the beginning; - return first list reverted (again) - ie. in order as required subsequently*) -fun dropwhile' equal (f1::f2::fs) (i1::i2::is) = - if equal f1 i1 then - if equal f2 i2 then dropwhile' equal (f2::fs) (i2::is) - else (rev (f1::f2::fs), i1::i2::is) - else raise error "dropwhile': did not start with equal elements" - | dropwhile' equal (f::fs) [i] = - if equal f i then (rev (f::fs), [i]) - else raise error "dropwhile': did not start with equal elements" - | dropwhile' equal [f] (i::is) = - if equal f i then ([f], i::is) - else raise error "dropwhile': did not start with equal elements"; -(* - fun equal a b = a=b; - val foder = [0,1,2,3,4,5]; val ifoder = [11,12,3,4,5]; - val r_foder = rev foder; val r_ifoder = rev ifoder; - dropwhile' equal r_foder r_ifoder; -> vval it = ([0, 1, 2, 3], [3, 12, 11]) : int list * int list - - val foder = [3,4,5]; val ifoder = [11,12,3,4,5]; - val r_foder = rev foder; val r_ifoder = rev ifoder; - dropwhile' equal r_foder r_ifoder; -> val it = ([3], [3, 12, 11]) : int list * int list - - val foder = [5]; val ifoder = [11,12,3,4,5]; - val r_foder = rev foder; val r_ifoder = rev ifoder; - dropwhile' equal r_foder r_ifoder; -> val it = ([5], [5, 4, 3, 12, 11]) : int list * int list - - val foder = [10,11,12,13,14,15]; val ifoder = [11,12,3,4,5]; - val r_foder = rev foder; val r_ifoder = rev ifoder; - dropwhile' equal r_foder r_ifoder; -> *** dropwhile': did not start with equal elements*) - -(*040214: version for concat_deriv*) -fun rev_deriv' (t, r, (t', a)) = (t', sym_Thm r, (t, a)); - -fun mk_tacis ro erls (t, r as Thm _, (t', a)) = - (Rewrite (rule2thm' r), - Rewrite' ("Isac.thy", fst ro, erls, false, - rule2thm' r, t, (t', a)), - (e_pos'(*to be updated before generate tacis!!!*), Uistate)) - | mk_tacis ro erls (t, r as Rls_ rls, (t', a)) = - (Rewrite_Set (rule2rls' r), - Rewrite_Set' ("Isac.thy", false, rls, t, (t', a)), - (e_pos'(*to be updated before generate tacis!!!*), Uistate)); - -(*fo = ifo excluded already in inform*) -fun concat_deriv rew_ord erls rules fo ifo = - let fun derivat ([]:(term * rule * (term * term list)) list) = e_term - | derivat dt = (#1 o #3 o last_elem) dt - fun equal (_,_,(t1, _)) (_,_,(t2, _)) = t1=t2 - val fod = make_deriv (Isac"") erls rules (snd rew_ord) NONE fo - val ifod = make_deriv (Isac"") erls rules (snd rew_ord) NONE ifo - in case (fod, ifod) of - ([], []) => if fo = ifo then (true, []) - else (false, []) - | (fod, []) => if derivat fod = ifo - then (true, fod) (*ifo is normal form*) - else (false, []) - | ([], ifod) => if fo = derivat ifod - then (true, ((map rev_deriv') o rev) ifod) - else (false, []) - | (fod, ifod) => - if derivat fod = derivat ifod (*common normal form found*) - then let val (fod', rifod') = - dropwhile' equal (rev fod) (rev ifod) - in (true, fod' @ (map rev_deriv' rifod')) end - else (false, []) - end; -(* - val ({rew_ord, erls, rules,...}, fo, ifo) = - (rep_rls Test_simplify, str2term "x+1+ -1*2=0", str2term "-2*1+(x+1)=0"); - (writeln o trtas2str) fod'; -> [" -(x + 1 + -1 * 2 = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (x + 1) = 0, []))"," -(-1 * 2 + (x + 1) = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (1 + x) = 0, []))"," -(-1 * 2 + (1 + x) = 0, Thm ("radd_left_commute","?x + (?y + ?z) = ?y + (?x + ?z)"), (1 + (-1 * 2 + x) = 0, []))"," -(1 + (-1 * 2 + x) = 0, Thm ("#mult_Float ((~1,0), (0,0)) __ ((2,0), (0,0))","-1 * 2 = -2"), (1 + (-2 + x) = 0, []))"] -val it = () : unit - (writeln o trtas2str) (map rev_deriv' rifod'); -> [" -(1 + (-2 + x) = 0, Thm ("sym_#mult_Float ((~2,0), (0,0)) __ ((1,0), (0,0))","-2 = -2 * 1"), (1 + (-2 * 1 + x) = 0, []))"," -(1 + (-2 * 1 + x) = 0, Thm ("sym_radd_left_commute","?y + (?x + ?z) = ?x + (?y + ?z)"), (-2 * 1 + (1 + x) = 0, []))"," -(-2 * 1 + (1 + x) = 0, Thm ("sym_radd_commute","?n + ?m = ?m + ?n"), (-2 * 1 + (x + 1) = 0, []))"] -val it = () : unit -*) - - -(*.compare inform with ctree.form at current pos by nrls; - if found, embed the derivation generated during comparison - if not, let the mat-engine compute the next ctree.form.*) -(*structure copied from complete_solve - CAUTION: tacis in returned calcstate' do NOT construct resulting ptp -- - all_modspec etc. has to be inserted at Subproblem'*) -(* val (tacis, c, ptp as (pt, pos as (p,p_))) = (tacis, ptp); - val (tacis, c, ptp as (pt, pos as (p,p_))) = cs'; - - val (tacis, c, ptp as (pt, pos as (p,p_))) = ([],[],(pt, lev_back pos)); - -----rec.call: - val (tacis, c, ptp as (pt, pos as (p,p_))) = cs'; - *) -fun compare_step ((tacis, c, ptp as (pt, pos as (p,p_))): calcstate') ifo = - let val fo = case p_ of Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - | _ => e_term (*on PblObj is fo <> ifo*); - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p)) - val {rew_ord, erls, rules,...} = rep_rls nrls - val (found, der) = concat_deriv rew_ord erls rules fo ifo; - in if found - then let val tacis' = map (mk_tacis rew_ord erls) der; - val (c', ptp) = embed_deriv tacis' ptp; - in ("ok", (tacis (*@ tacis'?WN050408*), c @ c', ptp)) end - else - if pos = ([], Res) - then ("no derivation found", (tacis, c, ptp): calcstate') - else let val cs' as (tacis, c', ptp) = nxt_solve_ ptp; - val cs' as (tacis, c'', ptp) = - case tacis of - ((Subproblem _, _, _)::_) => - let val ptp as (pt, (p,_)) = all_modspec ptp - val mI = get_obj g_metID pt p - in nxt_solv (Apply_Method' (mI, NONE, e_istate)) - e_istate ptp end - | _ => cs'; - in compare_step (tacis, c @ c' @ c'', ptp) ifo end - end; -(* writeln (trtas2str der); - *) - -(*.handle a user-input formula, which may be a CAS-command, too. -CAS-command: - create a calchead, and do 1 step - TOOODO.WN0602 works only for the root-problem !!! -formula, which is no CAS-command: - compare iform with calc-tree.form at pos by equ_nrls and all subsequent pos; - collect all the tacs applied by the way.*) -(*structure copied from autocalc*) -(* val (cs as (_, _, (pt, pos as (p, p_))): calcstate') = cs'; - val ifo = str2term ifo; - - val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) = - (cs', encode ifo); - val ((cs as (_, _, ptp as (pt, pos as (p, p_)))), istr)=(cs', (encode ifo)); - val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) = - (([],[],(pt,p)), (encode ifo)); - *) -fun inform (cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate') istr = - case parse (assoc_thy "Isac.thy") istr of -(* val SOME ifo = parse (assoc_thy "Isac.thy") istr; - *) - SOME ifo => - let val ifo = term_of ifo - val fo = case p_ of Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - | _ => #3 (get_obj g_origin pt p) - in if fo = ifo - then ("same-formula", cs) - (*thus ctree not cut with replaceFormula!*) - else case cas_input ifo of -(* val SOME (pt, _) = cas_input ifo; - *) - SOME (pt, _) => ("ok",([],[],(pt, (p, Met)))) - | NONE => - compare_step ([],[],(pt, - (*last step re-calc in compare_step TODO*) - lev_back pos)) ifo - end - | NONE => ("syntax error in '"^istr^"'", e_calcstate'); - - -(*------------------------------------------------------------------(**) -end -open inform; -(**)------------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/mathengine.sml --- a/src/Tools/isac/ME/mathengine.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,506 +0,0 @@ -(* The _functional_ mathematics engine, ie. without a state. - Input and output are Isabelle's formulae as strings. - authors: Walther Neuper 2000 - (c) due to copyright terms - -use"mathengine.sml"; -*) - -signature MATHENGINE = - sig - type nxt_ - (* datatype nxt_ = HElpless | Nexts of CalcHead.calcstate *) - type NEW - type lOc_ - (*datatype - lOc_ = - ERror of string - | UNsafe of CalcHead.calcstate' - | Updated of CalcHead.calcstate' *) - - val CalcTreeTEST : - fmz list -> - pos' * NEW * mout * (string * tac) * safe * ptree - - val TESTg_form : ptree * (int list * pos_) -> mout - val autocalc : - pos' list -> - pos' -> - (ptree * pos') * taci list -> - auto -> string * pos' list * (ptree * pos') - val detailstep : ptree -> pos' -> string * ptree * pos' - (* val e_tac_ : tac_ *) - val f2str : mout -> cterm' - (* val get_pblID : ptree * pos' -> pblID option *) - val initmatch : ptree -> pos' -> ptform - (* val loc_solve_ : - string * tac_ -> ptree * (int list * pos_) -> lOc_ *) - (* val loc_specify_ : tac_ -> ptree * pos' -> lOc_ *) - val locatetac : (*tests only*) - tac -> - ptree * (posel list * pos_) -> - string * (taci list * pos' list * (ptree * (posel list * pos_))) - val me : - tac'_ -> - pos' -> - NEW -> - ptree -> pos' * NEW * mout * tac'_ * safe * ptree - - val nxt_specify_ : ptree * (int list * pos_) -> calcstate'(*tests only*) - val set_method : metID -> ptree * pos' -> ptree * ocalhd - val set_problem : pblID -> ptree * pos' -> ptree * ocalhd - val set_theory : thyID -> ptree * pos' -> ptree * ocalhd - val step : pos' -> calcstate -> string * calcstate' - val trymatch : pblID -> ptree -> pos' -> ptform - val tryrefine : pblID -> ptree -> pos' -> ptform - end - - - -(*------------------------------------------------------------------(**) -structure MathEngine : MATHENGINE = -struct -(**)------------------------------------------------------------------*) - -fun get_pblID (pt, (p,_):pos') = - let val p' = par_pblobj pt p - val (_,pI,_) = get_obj g_spec pt p' - val (_,(_,oI,_),_) = get_obj g_origin pt p' - in if pI <> e_pblID then SOME pI - else if oI <> e_pblID then SOME oI - else NONE end; -(*fun get_pblID (pt, (p,_):pos') = - ((snd3 o (get_obj g_spec pt)) (par_pblobj pt p));*) - - -(*--vvv--dummies for test*) -val e_tac_ = Tac_ (Pure.thy,"","",""); -datatype lOc_ = - ERror of string (*after loc_specify, loc_solve*) -| UNsafe of calcstate' (*after loc_specify, loc_solve*) -| Updated of calcstate'; (*after loc_specify, loc_solve*) -fun loc_specify_ m (pt,pos) = -(* val pos = ip; - *) - let val (p,_,f,_,s,pt) = specify m pos [] pt; -(* val (_,_,_,_,_,pt')= specify m pos [] pt; - *) - in case f of - (Error' (Error_ e)) => ERror e - | _ => Updated ([], [], (pt,p)) end; - -(*. TODO push return-value cs' into solve and rename solve->loc_solve?_? .*) -(* val (m, pos) = ((mI,m), ip); - val (m,(pt,pos) ) = ((mI,m), ptp); - *) -fun loc_solve_ m (pt,pos) = - let val (msg, cs') = solve m (pt, pos); -(* val (tacis,dels,(pt',p')) = cs'; - (writeln o istate2str) (get_istate pt' p'); - (term2str o fst) (get_obj g_result pt' (fst p')); - *) - in case msg of - "ok" => Updated cs' - | msg => ERror msg - end; - -datatype nxt_ = - HElpless (**) - | Nexts of calcstate; (**) - -(*. locate a tactic in a script and apply it if possible .*) -(*report applicability of tac in tacis; pt is dropped in setNextTactic*) -fun locatetac _ (ptp as (_,([],Res))) = ("end-of-calculation", ([], [], ptp)) -(* val ptp as (pt, p) = (pt, p); - val ptp as (pt, p) = (pt, ip); - *) - | locatetac tac (ptp as (pt, p)) = - let val (mI,m) = mk_tac'_ tac; - in case applicable_in p pt m of - Notappl e => ("not-applicable", ([],[], ptp):calcstate') - | Appl m => -(* val Appl m = applicable_in p pt m; - *) - let val x = if member op = specsteps mI - then loc_specify_ m ptp else loc_solve_ (mI,m) ptp - in case x of - ERror e => ("failure", ([], [], ptp)) - (*FIXXXXXME: loc_specify_, loc_solve_ TOGETHER with dropping meOLD+detail.sml*) - | UNsafe cs' => ("unsafe-ok", cs') - | Updated (cs' as (_,_,(_,p'))) => - (*ev.SEVER.tacs like Begin_Trans*) - (if p' = ([],Res) then "end-of-calculation" else "ok", - cs')(*for -"- user to ask ? *) - end - end; - - -(*------------------------------------------------------------------ -fun init_detail ptp = e_calcstate;(*15.8.03.MISSING-->solve.sml!?*) -(*----------------------------------------------------from solve.sml*) - | nxt_solv (Detail_Set'(thy', rls, t)) (pt, p) = - let (*val rls = the (assoc(!ruleset',rls')) - handle _ => raise error ("solve: '"^rls'^"' not known");*) - val thy = assoc_thy thy'; - val (srls, sc, is) = - case rls of - Rrls {scr=sc as Rfuns {init_state=ii,...},...} => - (e_rls, sc, RrlsState (ii t)) - | Rls {srls=srls,scr=sc as Script s,...} => - (srls, sc, ScrState ([(one_scr_arg s,t)], [], - NONE, e_term, Sundef, true)); - val pt = update_tac pt (fst p) (Detail_Set (id_rls rls)); - val (p,cid,_,pt) = generate1 thy (Begin_Trans' t) is p pt; - val nx = (tac_2tac o fst3) (next_tac (thy',srls) (pt,p) sc is); - val aopt = applicable_in p pt nx; - in case aopt of - Notappl s => raise error ("solve Detail_Set: "^s) - (* val Appl m = aopt; - *) - | Appl m => solve ("discardFIXME",m) p pt end -------------------------------------------------------------------*) - - -(*iterated by nxt_me; there (the resulting) ptp dropped - may call nxt_solve Apply_Method --- thus evaluated here after solve.sml*) -(* val (ptp as (pt, pos as (p,p_))) = ptp; - val (ptp as (pt, pos as (p,p_))) = (pt,ip); - *) -fun nxt_specify_ (ptp as (pt, pos as (p,p_))) = - let val pblobj as (PblObj{meth,origin=origin as (oris,(dI',pI',mI'),_), - probl,spec=(dI,pI,mI),...}) = get_obj I pt p; - in if just_created_ pblobj (*by Subproblem*) andalso origin <> e_origin - then case mI' of - ["no_met"] => nxt_specif (Refine_Tacitly pI') (pt, (p, Pbl)) - | _ => nxt_specif Model_Problem (pt, (p,Pbl)) - else let val cpI = if pI = e_pblID then pI' else pI; - val cmI = if mI = e_metID then mI' else mI; - val {ppc,prls,where_,...} = get_pbt cpI; - val pre = check_preconds "thy 100820" prls where_ probl; - val pb = foldl and_ (true, map fst pre); - (*FIXME.WN0308: ~~~~~: just check true in itms of pbl/met?*) - val (_,tac) = - nxt_spec p_ pb oris (dI',pI',mI') (probl, meth) - (ppc, (#ppc o get_met) cmI) (dI, pI, mI); - in case tac of - Apply_Method mI => -(* val Apply_Method mI = tac; - *) - nxt_solv (Apply_Method' (mI, NONE, e_istate)) e_istate ptp - | _ => nxt_specif tac ptp end - end; - - -(*.specify a new method; - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method ' .*) -fun set_method (mI:metID) ptp = - let val ([(_, Specify_Method' (_, _, mits), _)], [], (pt, pos as (p,_))) = - nxt_specif (Specify_Method mI) ptp - val pre = [] (*...from Specify_Method'*) - val complete = true (*...from Specify_Method'*) - (*from Specify_Method' ? vvv, vvv ?*) - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p - in (pt, (complete, Met, hdf, mits, pre, spec):ocalhd) end; - -(* val ([(_, Specify_Method' (_, _, mits), _)], [],_) = - nxt_specif (Specify_Method mI) ptp; - *) - -(*.specify a new problem; - WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem ' .*) -(* val (pI, ptp) = (pI, (pt, ip)); - *) -fun set_problem pI (ptp: ptree * pos') = - let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)], - _, (pt, pos as (p,_))) = nxt_specif (Specify_Problem pI) ptp - (*from Specify_Problem' ? vvv, vvv ?*) - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p - in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end; - -fun set_theory (tI:thyID) (ptp: ptree * pos') = - let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)], - _, (pt, pos as (p,_))) = nxt_specif (Specify_Theory tI) ptp - (*from Specify_Theory' ? vvv, vvv ?*) - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p - in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end; - -(*.does a step forward; returns tactic used, ctree updated. -TODO.WN0512 redesign after specify-phase became more separated from solve-phase -arg ip: - calcstate -.*) -(* val (ip as (_,p_), (ptp as (pt,p), tacis)) = (get_pos 1 1, get_calc 1); - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (pos, cs); - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (p, ((pt, e_pos'),[])); - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (ip,cs); - *) -fun step ((ip as (_,p_)):pos') ((ptp as (pt,p), tacis):calcstate) = - let val pIopt = get_pblID (pt,ip); - in if (*p = ([],Res) orelse*) ip = ([],Res) - then ("end-of-calculation",(tacis, [], ptp):calcstate') else - case tacis of - (_::_) => -(* val((tac,_,_)::_) = tacis; - *) - if ip = p (*the request is done where ptp waits for*) - then let val (pt',c',p') = generate tacis (pt,[],p) - in ("ok", (tacis, c', (pt', p'))) end - else (case (if member op = [Pbl,Met] p_ - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip)) - handle _ => ([],[],ptp)(*e.g.by Add_Given "equality///"*) - of cs as ([],_,_) => ("helpless", cs) - | cs => ("ok", cs)) -(* val [] = tacis; - *) - | _ => (case pIopt of - NONE => ("no-fmz-spec", ([], [], ptp)) - | SOME pI => -(* val SOME pI = pIopt; - val cs=(if member op = [Pbl,Met] p_ andalso is_none(get_obj g_env pt (fst p)) - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip)) - handle _ => ([], ptp); - *) - (case (if member op = [Pbl,Met] p_ - andalso is_none (get_obj g_env pt (fst p)) - (*^^^^^^^^: Apply_Method without init_form*) - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip) ) - handle _ => ([],[],ptp)(*e.g.by Add_Giv"equality/"*) - of cs as ([],_,_) =>("helpless", cs)(*FIXXMEdel.handle*) - | cs => ("ok", cs))) - end; - -(* (nxt_solve_ (pt,ip)) handle e => print_exn e ; - - *) - - - - -(*.does several steps within one calculation as given by "type auto"; - the steps may arbitrarily go into and leave different phases, - i.e. specify-phase and solve-phase.*) -(*TODO.WN0512 ? redesign after the phases have been more separated - at the fron-end in 05: - eg. CompleteCalcHead could be done by a separate fun !!!*) -(* val (ip, cs as (ptp as (pt,p),tacis)) = (get_pos cI 1, get_calc cI); - val (ip, cs as (ptp as (pt,p),tacis)) = (pold, get_calc cI); - val (c, ip, cs as (ptp as (_,p),tacis), Step s) = - ([]:pos' list, pold, get_calc cI, auto); - *) -fun autocalc c ip (cs as (ptp as (_,p),tacis)) (Step s) = - if s <= 1 - then let val (str, (_, c', ptp)) = step ip cs;(*1*) - (*at least does 1 step, ev.1 too much*) - in (str, c@c', ptp) end - else let val (str, (_, c', ptp as (_, p))) = step ip cs; - in if str = "ok" - then autocalc (c@c') p (ptp,[]) (Step (s-1)) - else (str, c@c', ptp) end -(*handles autoord <= 3, autoord > 3 handled by all_/complete_solve*) - | autocalc c (pos as (_,p_)) ((pt,_), _(*tacis would help 1x in solve*))auto= -(* val (c:pos' list, (pos as (_,p_)),((pt,_),_),auto) = - ([], pold, get_calc cI, auto); - *) - if autoord auto > 3 andalso just_created (pt, pos) - then let val ptp = all_modspec (pt, pos); - in all_solve auto c ptp end - else - if member op = [Pbl, Met] p_ - then if not (is_complete_mod (pt, pos)) - then let val ptp = complete_mod (pt, pos) - in if autoord auto < 3 then ("ok", c, ptp) - else - if not (is_complete_spec ptp) - then let val ptp = complete_spec ptp - in if autoord auto = 3 then ("ok", c, ptp) - else all_solve auto c ptp - end - else if autoord auto = 3 then ("ok", c, ptp) - else all_solve auto c ptp - end - else - if not (is_complete_spec (pt,pos)) - then let val ptp = complete_spec (pt, pos) - in if autoord auto = 3 then ("ok", c, ptp) - else all_solve auto c ptp - end - else if autoord auto = 3 then ("ok", c, (pt, pos)) - else all_solve auto c (pt, pos) - else complete_solve auto c (pt, pos); -(* val pbl = get_obj g_pbl (fst ptp) []; - val (oris,_,_) = get_obj g_origin (fst ptp) []; -*) - - - - - -(*.initialiye matching; before 'tryMatch' get the pblID to match with: - if no pbl has been specified, take the init from origin.*) -(*fun initmatch pt (pos as (p,_):pos') = - let val PblObj {probl,origin=(os,(_,pI,_),_),spec=(dI',pI',mI'),...} = - get_obj I pt p - val pblID = if pI' = e_pblID - then (*TODO.WN051125 (#init o get_pbt) pI <<<*) - takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*) - else pI' - val spec = (dI',pblID,mI') - val {ppc,where_,prls,...} = get_pbt pblID - val (model_ok, (pbl, pre)) = - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os - in ModSpec (ocalhd_complete pbl pre spec, - Pbl, e_term, pbl, pre, spec) end;*) -fun initcontext_pbl pt (pos as (p,_):pos') = - let val PblObj {probl,origin=(os,(_,pI,_),hdl),spec=(dI',pI',mI'),...} = - get_obj I pt p - val pblID = if pI' = e_pblID - then (*TODO.WN051125 (#init o get_pbt) pI <<<*) - takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*) - else pI' - val {ppc,where_,prls,...} = get_pbt pblID - val (model_ok, (pbl, pre)) = - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os - in (model_ok, pblID, hdl, pbl, pre) end; - -fun initcontext_met pt (pos as (p,_):pos') = - let val PblObj {meth,origin=(os,(_,_,mI), _),spec=(_, _, mI'),...} = - get_obj I pt p - val metID = if mI' = e_metID - then (*TODO.WN051125 (#init o get_pbt) pI <<<*) - takelast (2, mI) (*FIXME.WN051125 a hack, impl.^^^*) - else mI' - val {ppc,pre,prls,scr,...} = get_met metID - val (model_ok, (pbl, pre)) = - match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os - in (model_ok, metID, scr, pbl, pre) end; - -(*.match the model of a problem at pos p - with the model-pattern of the problem with pblID*) -fun context_pbl pI pt (p:pos) = - let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p - val {ppc,where_,prls,...} = get_pbt pI - val (model_ok, (pbl, pre)) = - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os - in (model_ok, pI, hdl, pbl, pre) end; - -fun context_met mI pt (p:pos) = - let val PblObj {meth,origin=(os,_,hdl),...} = get_obj I pt p - val {ppc,pre,prls,scr,...} = get_met mI - val (model_ok, (pbl, pre)) = - match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os - in (model_ok, mI, scr, pbl, pre) end - - -(* val (pI, pt, pos as (p,_)) = (pblID, pt, p); - *) -fun tryrefine pI pt (pos as (p,_):pos') = - let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p - in case refine_pbl (assoc_thy "Isac.thy") pI probl of - NONE => (*copy from context_pbl*) - let val {ppc,where_,prls,...} = get_pbt pI - val (_, (pbl, pre)) = match_itms_oris (assoc_thy "Isac.thy") - probl (ppc,where_,prls) os - in (false, pI, hdl, pbl, pre) end - | SOME (pI, (pbl, pre)) => - (true, pI, hdl, pbl, pre) - end; - -(* val (pt, (pos as (p,p_):pos')) = (pt, ip); - *) -fun detailstep pt (pos as (p,p_):pos') = - let val nd = get_nd pt p - val cn = children nd - in if null cn - then if (is_rewset o (get_obj g_tac nd)) [(*root of nd*)] - then detailrls pt pos - else ("no-Rewrite_Set...", EmptyPtree, e_pos') - else ("donesteps", pt(*, get_formress [] ((lev_on o lev_dn) p) cn*), - (p @ [length (children (get_nd pt p))], Res) ) - end; - - - -(***. for mathematics authoring on sml-toplevel; no XML .***) - -type NEW = int list; -(* val sp = (dI',pI',mI'); - *) - -(*15.8.03 for me with loc_specify/solve, nxt_specify/solve - delete as soon as TESTg_form -> _mout_ dropped*) -fun TESTg_form ptp = -(* val ptp = (pt,p); - *) - let val (form,_,_) = pt_extract ptp - in case form of - Form t => Form' (FormKF (~1,EdUndef,0,Nundef,term2str t)) - | ModSpec (_,p_, head, gfr, pre, _) => - Form' (PpcKF (0,EdUndef,0,Nundef, - (case p_ of Pbl => Problem[] | Met => Method[], - itms2itemppc (assoc_thy"Isac.thy") gfr pre))) - end; - -(*.create a calc-tree; for use within sml: thus ^^^ NOT decoded to ^; - compare "fun CalcTree" which DOES decode.*) -fun CalcTreeTEST [(fmz, sp):fmz] = -(* val [(fmz, sp):fmz] = [(fmz, (dI',pI',mI'))]; - val [(fmz, sp):fmz] = [([], ("e_domID", ["e_pblID"], ["e_metID"]))]; - *) - let val cs as ((pt,p), tacis) = nxt_specify_init_calc (fmz, sp) - val tac = case tacis of [] => Empty_Tac | _ => (#1 o hd) tacis - val f = TESTg_form (pt,p) - in (p, []:NEW, f, (tac2IDstr tac, tac), Sundef, pt) end; - -(*for tests > 15.8.03 after separation setnexttactic / nextTac: - external view: me should be used by math-authors as done so far - internal view: loc_specify/solve, nxt_specify/solve used - i.e. same as in setnexttactic / nextTac*) -(*ENDE TESTPHASE 08/10.03: - NEW loeschen, eigene Version von locatetac, step - meNEW, CalcTreeTEST: tac'_ -replace-> tac, remove [](cid) *) - -(* val ((_,tac), p, _, pt) = (nxt, p, c, pt); - *) -fun me ((_,tac):tac'_) (p:pos') (_:NEW(*remove*)) (pt:ptree) = - let val (pt, p) = -(* val (msg, (tacis, pos's, (pt',p'))) = locatetac tac (pt,p); - p = ([1, 9], Res); - (writeln o istate2str) (get_istate pt p); - *) - (*locatetac is here for testing by me; step would suffice in me*) - case locatetac tac (pt,p) of - ("ok", (_, _, ptp)) => ptp - | ("unsafe-ok", (_, _, ptp)) => ptp - | ("not-applicable",_) => (pt, p) - | ("end-of-calculation", (_, _, ptp)) => ptp - | ("failure",_) => raise error "sys-error"; - val (_, ts) = -(* val (eee, (ts, _, (pt'',_))) = step p ((pt, e_pos'),[]); - *) - (case step p ((pt, e_pos'),[]) of - ("ok", (ts as (tac,_,_)::_, _, _)) => ("",ts) - | ("helpless",_) => ("helpless: cannot propose tac", []) - | ("no-fmz-spec",_) => raise error "no-fmz-spec" - | ("end-of-calculation", (ts, _, _)) => ("",ts)) - handle _ => raise error "sys-error"; - val tac = case ts of tacis as (_::_) => -(* val tacis as (_::_) = ts; - *) - let val (tac,_,_) = last_elem tacis - in tac end - | _ => if p = ([],Res) then End_Proof' - else Empty_Tac; - (*form output comes from locatetac*) - in(p:pos',[]:NEW, TESTg_form (pt, p), - (tac2IDstr tac, tac):tac'_, Sundef, pt) end; - -(*for quick test-print-out, until 'type inout' is removed*) -fun f2str (Form' (FormKF (_, _, _, _, cterm'))) = cterm'; - - - -(*------------------------------------------------------------------(**) -end -open MathEngine; -(**)------------------------------------------------------------------*) - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/mstools.sml --- a/src/Tools/isac/ME/mstools.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,969 +0,0 @@ -(* Types and tools for 'modeling' und 'specifying' to be used in - modspec.sml. The types are separated from calchead.sml into this file, - because some of them are stored in the calc-tree, and thus are required - _before_ ctree.sml. - author: Walther Neuper - (c) due to copyright terms - -use"ME/mstools.sml" (*re-evaluate sml/ from scratch!*); -use"mstools.sml"; -12345678901234567890123456789012345678901234567890123456789012345678901234567890 - 10 20 30 40 50 60 70 80 -*) - -signature SPECIFY_TOOLS = - sig - type envv - datatype - item = - Correct of cterm' - | False of cterm' - | Incompl of cterm' - | Missing of cterm' - | Superfl of string - | SyntaxE of string - | TypeE of string - val item2str : item -> string - type itm - val itm2str_ : Proof.context -> itm -> string - datatype - itm_ = - Cor of (term * term list) * (term * term list) - | Inc of (term * term list) * (term * term list) - | Mis of term * term - | Par of cterm' - | Sup of term * term list - | Syn of cterm' - | Typ of cterm' - val itm_2str : itm_ -> string - val itm_2str_ : Proof.context -> itm_ -> string - val itms2str_ : Proof.context -> itm list -> string - type 'a ppc - val ppc2str : - {Find: string list, With: string list, Given: string list, - Where: string list, Relate: string list} -> string - datatype - match = - Matches of pblID * item ppc - | NoMatch of pblID * item ppc - val match2str : match -> string - datatype - match_ = - Match_ of pblID * (itm list * (bool * term) list) - | NoMatch_ - val matchs2str : match list -> string - type ori - val ori2str : ori -> string - val oris2str : ori list -> string - type preori - val preori2str : preori -> string - val preoris2str : preori list -> string - type penv - (* val penv2str_ : Proof.context -> penv -> string *) - type vats - (*----------------------------------------------------------------------*) - val all_ts_in : itm_ list -> term list - val check_preconds : - 'a -> - rls -> - term list -> itm list -> (bool * term) list - val check_preconds' : - rls -> - term list -> - itm list -> 'a -> (bool * term) list - (* val chkpre2item : rls -> term -> bool * item *) - val pres2str : (bool * term) list -> string - (* val evalprecond : rls -> term -> bool * term *) - (* val cnt : itm list -> int -> int * int *) - val comp_dts : theory -> term * term list -> term - val comp_dts' : term * term list -> term - val comp_dts'' : term * term list -> string - val comp_ts : term * term list -> term - val d_in : itm_ -> term - val de_item : item -> cterm' - val dest_list : term * term list -> term list (* for testing *) - val dest_list' : term -> term list - val dts2str : term * term list -> string - val e_itm : itm - (* val e_listBool : term *) - (* val e_listReal : term *) - val e_ori : ori - val e_ori_ : ori - val empty_ppc : item ppc - (* val empty_ppc_ct' : cterm' ppc *) - (* val getval : term * term list -> term * term *) - (*val head_precond : - domID * pblID * 'a -> - term option -> - rls -> - term list -> - itm list -> 'b -> term * (bool * term) list*) - (* val init_item : string -> item *) - (* val is_matches : match -> bool *) - (* val is_matches_ : match_ -> bool *) - val is_var : term -> bool - (* val item_ppc : - string ppc -> item ppc *) - val itemppc2str : item ppc -> string - (* val matches_pblID : match -> pblID *) - val max2 : ('a * int) list -> 'a * int - val max_vt : itm list -> int - val mk_e : itm_ -> (term * term) list - val mk_en : int -> itm -> (term * term) list - val mk_env : itm list -> (term * term) list - val mkval : 'a -> term list -> term - val mkval' : term list -> term - (* val pblID_of_match : match -> pblID *) - val pbl_ids : Proof.context -> term -> term -> term list - val pbl_ids' : 'a -> term -> term list -> term list - (* val pen2str : theory -> term * term list -> string *) - val penvval_in : itm_ -> term list - val refined : match list -> pblID - val refined_ : - match_ list -> match_ option - (* val refined_IDitms : - match list -> match option *) - val split_dts : 'a -> term -> term * term list - val split_dts' : term * term -> term list - (* val take_apart : term -> term list *) - (* val take_apart_inv : term list -> term *) - val ts_in : itm_ -> term list - (* val unique : term *) - val untouched : itm list -> bool - val upd : - Proof.context -> - (''a * (''b * term list) list) list -> - term -> - ''b * term -> ''a -> ''a * (''b * term list) list - val upd_envv : - Proof.context -> - envv -> - vats -> - term -> term -> term -> envv - val upd_penv : - Proof.context -> - (''a * term list) list -> - term -> ''a * term -> (''a * term list) list - (* val upds_envv : - Proof.context -> - envv -> - (vats * term * term * term) list -> - envv *) - val vts_cnt : int list -> itm list -> (int * int) list - val vts_in : itm list -> int list - (* val w_itms2str_ : Proof.context -> itm list -> unit *) - end - -(*----------------------------------------------------------*) -structure SpecifyTools : SPECIFY_TOOLS = -struct -(*----------------------------------------------------------*) -val e_listReal = (term_of o the o (parse (theory "Script"))) "[]::(real list)"; -val e_listBool = (term_of o the o (parse (theory "Script"))) "[]::(bool list)"; - -(*.take list-term apart w.r.t. handling elementwise input.*) -fun take_apart t = - let val elems = isalist2list t - in map ((list2isalist (type_of (hd elems))) o single) elems end; -(*val t = str2term "[a, b]"; -> val ts = take_apart t; writeln (terms2str ts); -["[a]","[b]"] - -> t = (take_apart_inv o take_apart) t; -true*) -fun take_apart_inv ts = - let val elems = (flat o (map isalist2list)) ts; - in list2isalist (type_of (hd elems)) elems end; -(*val ts = [str2term "[a]", str2term "[b]"]; -> val t = take_apart_inv ts; term2str t; -"[a, b]" - -ts = (take_apart o take_apart_inv) ts; -true*) - - - - -(*.revert split_dts only for ts; compare comp_dts.*) -fun comp_ts (d, ts) = - if is_list_dsc d - then if is_list (hd ts) - then if is_unl d - then (hd ts) (*e.g. someList [1,3,2]*) - else (take_apart_inv ts) - (* SML[ [a], [b] ]SML --> [a,b] *) - else (hd ts) (*a variable or metavariable for a list*) - else (hd ts); -(*.revert split_. - WN050903 we do NOT know which is from subtheory, description or term; - typecheck thus may lead to TYPE-error 'unknown constant'; - solution: typecheck with Isac.thy; i.e. arg 'thy' superfluous*) -(*fun comp_dts thy (d,[]) = - cterm_of (*(sign_of o assoc_thy) "Isac.thy"*) - (theory "Isac") - (*comp_dts:FIXXME stay with term for efficiency !!!*) - (if is_reall_dsc d then (d $ e_listReal) - else if is_booll_dsc d then (d $ e_listBool) - else d) - | comp_dts thy (d,ts) = - (cterm_of (*(sign_of o assoc_thy) "Isac.thy"*) - (theory "Isac") - (*comp_dts:FIXXME stay with term for efficiency !!*) - (d $ (comp_ts (d, ts))) - handle _ => raise error ("comp_dts: "^(term2str d)^ - " $ "^(term2str (hd ts))));*) -fun comp_dts thy (d,[]) = - (if is_reall_dsc d then (d $ e_listReal) - else if is_booll_dsc d then (d $ e_listBool) - else d) - | comp_dts thy (d,ts) = - (d $ (comp_ts (d, ts))) - handle _ => raise error ("comp_dts: "^(term2str d)^ - " $ "^(term2str (hd ts))); -(*25.8.03*) -fun comp_dts' (d,[]) = - if is_reall_dsc d then (d $ e_listReal) - else if is_booll_dsc d then (d $ e_listBool) - else d - | comp_dts' (d,ts) = (d $ (comp_ts (d, ts))) - handle _ => raise error ("comp_dts': "^(term2str d)^ - " $ "^(term2str (hd ts))); -(*val t = str2term "maximum A"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -val it = "maximum A" : cterm -> val t = str2term "fixedValues [r=Arbfix]"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"fixedValues [r = Arbfix]" -> val t = str2term "valuesFor [a]"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"valuesFor [a]" -> val t = str2term "valuesFor [a,b]"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"valuesFor [a, b]" -> val t = str2term "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -relations [A = a * b, (a / 2) ^^^ 2 + (b / 2) ^^^ 2 = r ^^^ 2]" -> val t = str2term "boundVariable a"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"boundVariable a" -> val t = str2term "interval {x::real. 0 <= x & x <= 2*r}"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"interval {x. 0 <= x & x <= 2 * r}" - -> val t = str2term "equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"equality (sqrt (9 + 4 * x) = sqrt x + sqrt (5 + x))" -> val t = str2term "solveFor x"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"solveFor x" -> val t = str2term "errorBound (eps=0)"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"errorBound (eps = 0)" -> val t = str2term "solutions L"; -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts); -"solutions L" - -before 6.5.03: -> val t = (term_of o the o (parse thy)) "testdscforlist [#1]"; -> val (d,ts) = split_dts t; -> comp_dts thy (d,ts); -val it = "testdscforlist [#1]" : cterm - -> val t = (term_of o the o (parse thy)) "(A::real)"; -> val (d,ts) = split_dts t; -val d = Const ("empty","empty") : term -val ts = [Free ("A","RealDef.real")] : term list -> val t = (term_of o the o (parse thy)) "[R=(R::real)]"; -> val (d,ts) = split_dts t; -val d = Const ("empty","empty") : term -val ts = [Const # $ Free # $ Free (#,#)] : term list -> val t = (term_of o the o (parse thy)) "[#1,#2]"; -> val (d,ts) = split_dts t; -val ts = [Free ("#1","'a"),Free ("#2","'a")] : NOT WANTED -*) - -(*for input_icalhd 11.03*) -fun comp_dts'' (d,[]) = - if is_reall_dsc d then term2str (d $ e_listReal) - else if is_booll_dsc d then term2str (d $ e_listBool) - else term2str d - | comp_dts'' (d,ts) = term2str (d $ (comp_ts (d, ts))) - handle _ => raise error ("comp_dts'': "^(term2str d)^ - " $ "^(term2str (hd ts))); - - - - - - -(* this may decompose an object-language isa-list; - use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*) -fun dest_list' t = if is_list t then isalist2list t else [t]; - -(*fun is_metavar (Free (str, _)) = - if (last_elem o explode) str = "_" then true else false - | is_metavar _ = false;*) -fun is_var (Free _) = true - | is_var _ = false; - -(*.special handling for lists. ?WN:14.5.03 ??!?*) -fun dest_list (d,ts) = - let fun dest t = - if is_list_dsc d andalso not (is_unl d) - andalso not (is_var t) (*..for pbt*) - then isalist2list t else [t] - in (flat o (map dest)) ts end; - - -(*.decompose an input into description, terms (ev. elems of lists), - and the value for the problem-environment; inv to comp_dts .*) -(*WN.8.6.03: corrected with minimal effort, -fn : theory -> term -> - term * description - term list * lists decomposed for elementwise input - term list pbl_ids not _HERE_: dont know which list-elems input*) -fun split_dts thy (t as d $ arg) = - if is_dsc d - then if is_list_dsc d - then if is_list arg - then if is_unl d - then (d, [arg]) (*e.g. someList [1,3,2]*) - else (d, take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*) - else (d, [arg]) (*a variable or metavariable for a list*) - else (d, [arg]) - else (e_term, dest_list' t(*9.01 ???*)) - | split_dts thy t = (*either dsc or term*) - let val (h,argl) = strip_comb t - in if (not o is_dsc) h then (e_term, dest_list' t) - else (h, dest_list (h,argl)) - end; -(* tests see fun comp_dts - -> val t = str2term "someList []"; -> val (_,ts) = split_dts thy t; writeln (terms2str ts); -["[]"] -> val t = str2term "valuesFor []"; -> val (_,ts) = split_dts thy t; writeln (terms2str ts); -["[]"]*) - -(*.version returning ts only.*) -fun split_dts' (d, arg) = - if is_dsc d - then if is_list_dsc d - then if is_list arg - then if is_unl d - then ([arg]) (*e.g. someList [1,3,2]*) - else (take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*) - else ([arg]) (*a variable or metavariable for a list*) - else ([arg]) - else (dest_list' arg(*9.01 ???*)) - | split_dts' (d, t) = (*either dsc or term; 14.5.03 only copied*) - let val (h,argl) = strip_comb t - in if (not o is_dsc) h then (dest_list' t) - else (dest_list (h,argl)) - end; - - - - - -(*27.8.01: problem-environment -WN.6.5.03: FIXXME reconsider if penv is worth the effort -- - -- just rerun a whole expl with num/var may show the same ?! -WN.9.5.03: penv-concept stalled, immediately generate script env ! - but [#0, epsilon] only outcommented for eventual reconsideration -*) -type penv = (term (*err_*) - * (term list) (*[#0, epsilon] 9.5.03 outcommented*) - ) list; -fun pen2str ctxt (t, ts) = - pair2str(Syntax.string_of_term ctxt t, - (strs2str' o map (Syntax.string_of_term ctxt)) ts); -fun penv2str_ thy (penv:penv) = (strs2str' o (map (pen2str thy))) penv; - -(* - 9.5.03: still unused, but left for eventual future development*) -type envv = (int * penv) list; (*over variants*) - -(*. 14.9.01: not used after putting penv-values into itm_ - make the result of split_* a value of problem-environment .*) -fun mkval dsc [] = raise error "mkval called with []" - | mkval dsc [t] = t - | mkval dsc ts = list2isalist ((type_of o hd) ts) ts; -(*WN.12.12.03*) -fun mkval' x = mkval e_term x; - - - -(*. get the constant value from a penv .*) -fun getval (id, values) = - case values of - [] => raise error ("penv_value: no values in '"^ - (Syntax.string_of_term (thy2ctxt' "Tools") id)) - | [v] => (id, v) - | (v1::v2::_) => (case v1 of - Const ("Script.Arbfix",_) => (id, v2) - | _ => (id, v1)); -(* - val e_ = (term_of o the o (parse thy)) "e_::bool"; - val ev = (term_of o the o (parse thy)) "#4 + #3 * x^^^#2 = #0"; - val v_ = (term_of o the o (parse thy)) "v_"; - val vv = (term_of o the o (parse thy)) "x"; - val r_ = (term_of o the o (parse thy)) "err_::bool"; - val rv1 = (term_of o the o (parse thy)) "#0"; - val rv2 = (term_of o the o (parse thy)) "eps"; - - val penv = [(e_,[ev]),(v_,[vv]),(r_,[rv2,rv2])]:penv; - map getval penv; -[(Free ("e_","bool"), - Const (#,#) $ (# $ # $ (# $ #)) $ Free ("#0","RealDef.real")), - (Free ("v_","RealDef.real"),Free ("x","RealDef.real")), - (Free ("err_","bool"),Free ("#0","RealDef.real"))] : (term * term) list -*) - - -(*23.3.02 TODO: ideas on redesign of type itm_,type item,type ori,type item ppc -(1) kinds of itms: - (1.1) untouched: for modeling only dsc displayed(impossible after match_itms) - =(presently) Mis (? should be Inc initially, and Mis after match_itms?) - (1.2) Syn,Typ,Sup: not related to oris - Syn, Typ (presently) should be accepted in appl_add (instead Error') - Sup (presently) should be accepted in appl_add (instead Error') - _could_ be w.r.t current vat (and then _is_ related to vat - Mis should _not_ be made Inc ((presently, by appl_add & match_itms) -- dsc in itm_ is timeconsuming -- keep id for respective queries ? -- order of items in ppc should be stable w.r.t order of itms - -- stepwise input of itms --- match_itms (in one go) ..not coordinated - - unify code - - match_itms / match_itms_oris ..2 versions ?! - (fast, for refine / slow, for modeling) - -- clarify: efficiency <--> simplicity !!! - ?: shift dsc itm_ -> itm | discard int in ori,itm | take int instead dsc - | take int for perserving order of item ppc in itms - | make all(!?) handling of itms stable against reordering(?) - | field in ori ?? (not from fmz!) -- meant for efficiency (not doc!???) - -"- "#undef" ?= not touched ?= (id,..) ------------------------------------------------------------------ -27.3.02: -def: type pbt = (field, (dsc, pid)) - -(1) fmz + pbt -> oris -(2) input + oris -> itm -(3) match_itms : schnell(?) f"ur refine - match_itms_oris : r"uckmeldung f"ur item ppc - -(1.1) in oris fehlt daher pid: (i,v,f,d,ts,pid) ----------- ^^^^^ --- dh. pbt meist als argument zu viel !!! - -(3.1) abwarten, wie das matchen mehr unterschiedlicher pbt's sich macht; - wenn Problem pbt v"ollig neue, dann w"are eigentlich n"otig ????: - (a) (_,_,d1,ts,_):ori + pbt -> (i,vt,d2,ts,pid) dh.vt neu ???? - (b) -*) - - - - -(*the internal representation of a models' item - - 4.9.01: not consistent: - after Init_Proof 'Inc', but after copy_probl 'Mis' - for same situation - (involves 'is_error'); - bool in itm really necessary ???*) -datatype itm_ = - Cor of (term * (* description *) - (term list)) * (* for list: elem-wise input *) - (*split_dts <-> comp_dts*) - (term * (term list)) (* elem of penv *) - (*9.5.03: ---- is already for script -- penv delayed to future*) - | Syn of cterm' - | Typ of cterm' - | Inc of (term * (term list)) * (term * (term list)) (*lists, - + init_pbl WN.11.03 FIXXME: empty penv .. bad - init_pbl should return Mis !!!*) - | Sup of (term * (term list)) (* user-input not found in pbt(+?oris?11.03)*) - | Mis of (term * term) (* after re-specification pbt-item not found - in pbl: only dsc, pid_*) - | Par of cterm'; (*internal state from fun parsitm*) - -type vats = int list; (*variants in formalizations*) - -(*.data-type for working on pbl/met-ppc: - in pbl initially holds descriptions (only) for user guidance.*) -type itm = - int * (* id =0 .. untouched - descript (only) from init - 23.3.02: seems to correspond to ori (fun insert_ppc) - <> maintain order in item ppc?*) - vats * (* variants - copy from ori *) - bool * (* input on this item is not/complete *) - string * (* #Given | #Find | #Relate *) - itm_; (* *) -(* use"ME/sequent.sml"; - *) -val e_itm = (0,[],false,"e_itm",Syn"e_itm"):itm; -(*in CalcTree/Subproblem an 'untouched' model is created - FIXME.WN.9.03 model should be filled to 'untouched' by Model/Refine_Problem*) -fun untouched (itms: itm list) = - foldl and_ (true ,map ((curry op= 0) o #1) itms); -(*> untouched []; -val it = true : bool -> untouched [e_itm]; -val it = true : bool -> untouched [e_itm, (1,[],false,"e_itm",Syn "e_itm")]; -val it = false : bool*) - - - - - -(* find most frequent variant v in itms *) - -fun vts_in itms = (distinct o flat o (map #2)) (itms:itm list); - -fun cnt itms v = (v,(length o (filter (curry op= v)) o - flat o (map #2)) (itms:itm list)); -fun vts_cnt vts itms = map (cnt itms) vts; -fun max2 [] = raise error "max2 of []" - | max2 (y::ys) = - let fun mx (a,x) [] = (a,x) - | mx (a,x) ((b,y)::ys) = - if x < y then mx (b,y) ys else mx (a,x) ys; -in mx y ys end; - -(*. find the variant with most items already input .*) -fun max_vt itms = - let val vts = (vts_cnt (vts_in itms)) itms; - in if vts = [] then 0 else (fst o max2) vts end; - - -(* TODO ev. make more efficient by avoiding flat *) -fun mk_e (Cor (_, iv)) = [getval iv] - | mk_e (Syn _) = [] - | mk_e (Typ _) = [] - | mk_e (Inc (_, iv)) = [getval iv] - | mk_e (Sup _) = [] - | mk_e (Mis _) = []; -fun mk_en vt ((i,vts,b,f,itm_):itm) = - if member op = vts vt then mk_e itm_ else []; -(*. extract the environment from an item list; - takes the variant with most items .*) -fun mk_env itms = - let val vt = max_vt itms - in (flat o (map (mk_en vt))) itms end; - - - -(*. example as provided by an author, complete w.r.t. pbt specified - not touched by any user action .*) -type ori = (int * (* id: 10.3.00ff impl. only <>0 .. touched - 21.3.02: insert_ppc needs it ! ?:purpose maintain - order in item ppc ???*) - vats * (* variants 21.3.02: related to pbt..discard ?*) - string * (* #Given | #Find | #Relate 21.3.02: discard ?*) - term * (* description *) - term list (* isalist2list t | [t] *) - ); -val e_ori_ = (0,[],"",e_term,[e_term]):ori; -val e_ori = (0,[],"",e_term,[e_term]):ori; - -fun ori2str ((i,vs,fi,t,ts):ori) = - "("^(string_of_int i)^", "^((strs2str o (map string_of_int)) vs)^", "^fi^","^ - (term2str t)^", "^((strs2str o (map term2str)) ts)^")"; -val oris2str = - let val s = !show_types - val _ = show_types:= true - val str = (strs2str' o (map (linefeed o ori2str))) - val _ = show_types:= s - in str end; - -(*.an or without leading integer.*) -type preori = (vats * - string * - term * - term list); -fun preori2str ((vs,fi,t,ts):preori) = - "("^((strs2str o (map string_of_int)) vs)^", "^fi^", "^ - (term2str t)^", "^((strs2str o (map term2str)) ts)^")"; -val preoris2str = (strs2str' o (map (linefeed o preori2str))); - -(*. given the input value (from split_dts) - make the value in a problem-env according to description-type .*) -(*28.8.01: .nam and .una impl. properly, others copied .. TODO*) -fun pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) v = - if is_list v - then [v] (*eg. [r=Arbfix]*) - else (case v of (*eg. eps=#0*) - (Const ("op =",_) $ l $ r) => [r,l] - | _ => raise error ("pbl_ids Tools.nam: no equality " - ^(Syntax.string_of_term ctxt v))) - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.una",_)]))) v = [v] - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) v = [v] - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.str",_)]))) v = [v] - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) v = [v] - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))v = [v] - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))v = [v] - | pbl_ids ctxt _ v = raise error ("pbl_ids: not implemented for " - ^(Syntax.string_of_term ctxt v)); -(* -val t as t1 $ t2 = str2term "antiDerivativeName M_b"; -pbl_ids ctxt t1 t2; - - val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]"; - val (d,argl) = strip_comb t; - is_dsc d; (*see split_dts*) - dest_list (d,argl); - val (_ $ v) = t; - is_list v; - pbl_ids ctxt d v; -[Const ("List.list.Cons","[bool, bool List.list] => bool List.list") $ - (Const # $ Free # $ Const (#,#)) $ Const ("List.list.Nil","bool List.. - - val (dsc,vl) = (split_dts o term_of o the o (parse thy)) "solveFor x"; -val dsc = Const ("Descript.solveFor","RealDef.real => Tools.una") : term -val vl = Free ("x","RealDef.real") : term - - val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_"; - pbl_ids ctxt dsc vl; -val it = [Free ("x","RealDef.real")] : term list - - val (dsc,vl) = (split_dts o term_of o the o(parse thy)) - "errorBound (eps=#0)"; - val (dsc,id) = (split_did o term_of o the o(parse thy)) "errorBound err_"; - pbl_ids ctxt dsc vl; -val it = [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")] : term list *) - -(*. given an already input itm, ((14.9.01: no difference to pbl_ids jet!!)) - make the value in a problem-env according to description-type .*) -(*28.8.01: .nam and .una impl. properly, others copied .. TODO*) -fun pbl_ids' (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) vs = - (case vs of - [] => raise error ("pbl_ids' Tools.nam called with []") - | [t] => (case t of (*eg. eps=#0*) - (Const ("op =",_) $ l $ r) => [r,l] - | _ => raise error ("pbl_ids' Tools.nam: no equality " - ^(Syntax.string_of_term (thy2ctxt' "Isac")t))) - | vs' => vs (*14.9.01: ???TODO *)) - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.una",_)]))) vs = vs - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) vs = vs - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.str",_)]))) vs = vs - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) vs = vs - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))vs = vs - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))vs = vs - | pbl_ids' _ vs = - raise error ("pbl_ids': not implemented for " - ^(terms2str vs)); -(*9.5.03 penv postponed: pbl_ids'*) -fun pbl_ids' thy d vs = [comp_ts (d, vs)]; - - -(*14.9.01: not used after putting values for penv into itm_ - WN.5.5.03: used in upd .. upd_envv*) -fun upd_penv ctxt penv dsc (id, vl) = -(writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; - writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; - writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; - overwrite (penv, (id, pbl_ids ctxt dsc vl)) -); -(* - val penv = []; - val (dsc,vl) = (split_did o term_of o the o (parse thy)) "solveFor x"; - val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_"; - val penv = upd_penv thy penv dsc (id, vl); -[(Free ("v_","RealDef.real"), - [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")])] -: (term * term list) list - - val (dsc,vl) = (split_did o term_of o the o(parse thy))"errorBound (eps=#0)"; - val (dsc,id) = (split_did o term_of o the o(parse thy))"errorBound err_"; - upd_penv thy penv dsc (id, vl); -[(Free ("v_","RealDef.real"), - [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")]), - (Free ("err_","bool"), - [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])] -: (term * term list) list ^.........!!!! -*) - -(*WN.9.5.03: not reconsidered; looks strange !!!*) -fun upd thy envv dsc (id, vl) i = - let val penv = case assoc (envv, i) of - SOME e => e - | NONE => []; - val penv' = upd_penv thy penv dsc (id, vl); - in (i, penv') end; -(* - val i = 2; - val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv; - val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b"; - val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_"; - upd thy envv dsc (id, vl) i; -val it = (2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])]) - : int * (term * term list) list*) - - -(*14.9.01: not used after putting pre-penv into itm_*) -fun upd_envv thy (envv:envv) (vats:vats) dsc id vl = - let val vats = if length vats = 0 - then (*unknown id to _all_ variants*) - if length envv = 0 then [1] - else (intsto o length) envv - else vats - fun isin vats (i,_) = member op = vats i; - val envs_notin_vat = filter_out (isin vats) envv; - in ((map (upd thy envv dsc (id, vl)) vats) @ envs_notin_vat):envv end; -(* - val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv; - - val vats = [2] - val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b"; - val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_"; - val envv = upd_envv thy envv vats dsc id vl; -val envv = [(2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])] - : (int * (term * term list) list) list - - val vats = [1,2,3]; - val (dsc,vl) = (split_did o term_of o the o(parse thy))"maximum A"; - val (dsc,id) = (split_did o term_of o the o(parse thy))"maximum m_"; - upd_envv thy envv vats dsc id vl; -[(1,[(Free ("m_","bool"),[Free ("A","bool")])]), - (2, - [(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")]), - (Free ("m_","bool"),[Free ("A","bool")])]), - (3,[(Free ("m_","bool"),[Free ("A","bool")])])] -: (int * (term * term list) list) list - - - val env = []:envv; - val (d,ts) = (split_dts o term_of o the o (parse thy)) - "fixedValues [r=Arbfix]"; - val (_,id) = (split_did o term_of o the o (parse thy))"fixedValues fix_"; - val vats = [1,2,3]; - val env = upd_envv thy env vats d id (mkval ts); -*) - -(*. update envv by folding from a list of arguments .*) -fun upds_envv thy envv [] = envv - | upds_envv thy envv ((vs, dsc, id, vl)::ps) = - upds_envv thy (upd_envv thy envv vs dsc id vl) ps; -(* eval test-maximum.sml until Specify_Method ... - val PblObj{probl=(_,pbl),origin=(_,(_,_,mI),_),...} = get_obj I pt []; - val met = (#ppc o get_met) mI; - - val envv = []; - val eargs = flat eargs; - val (vs, dsc, id, vl) = hd eargs; - val envv = upds_envv thy envv [(vs, dsc, id, vl)]; - - val (vs, dsc, id, vl) = hd (tl eargs); - val envv = upds_envv thy envv [(vs, dsc, id, vl)]; - - val (vs, dsc, id, vl) = hd (tl (tl eargs)); - val envv = upds_envv thy envv [(vs, dsc, id, vl)]; - - val (vs, dsc, id, vl) = hd (tl (tl (tl eargs))); - val envv = upds_envv thy envv [(vs, dsc, id, vl)]; -[(1, - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), - (Free ("m_","bool"),[Free (#,#)]), - (Free ("vs_","bool List.list"),[# $ # $ Const #]), - (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]), - (2, - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), - (Free ("m_","bool"),[Free (#,#)]), - (Free ("vs_","bool List.list"),[# $ # $ Const #]), - (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]), - (3, - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]), - (Free ("m_","bool"),[Free (#,#)]), - (Free ("vs_","bool List.list"),[# $ # $ Const #])])] : envv *) - -(*for _output_ of the items of a Model*) -datatype item = - Correct of cterm' (*labels a correct formula (type cterm')*) - | SyntaxE of string (**) - | TypeE of string (**) - | False of cterm' (*WN050618 notexistent in itm_: only used in Where*) - | Incompl of cterm' (**) - | Superfl of string (**) - | Missing of cterm'; -fun item2str (Correct s) ="Correct " ^ s - | item2str (SyntaxE s) ="SyntaxE " ^ s - | item2str (TypeE s) ="TypeE " ^ s - | item2str (False s) ="False " ^ s - | item2str (Incompl s) ="Incompl " ^ s - | item2str (Superfl s) ="Superfl " ^ s - | item2str (Missing s) ="Missing " ^ s; -(*make string for error-msgs*) -fun itm_2str_ ctxt (Cor ((d,ts), penv)) = - "Cor " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ," - ^ pen2str ctxt penv - | itm_2str_ ctxt (Syn c) = "Syn " ^ c - | itm_2str_ ctxt (Typ c) = "Typ " ^ c - | itm_2str_ ctxt (Inc ((d,ts), penv)) = - "Inc " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ," - ^ pen2str ctxt penv - | itm_2str_ ctxt (Sup (d,ts)) = - "Sup " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) - | itm_2str_ ctxt (Mis (d,pid))= - "Mis "^ Syntax.string_of_term ctxt d ^ - " "^ Syntax.string_of_term ctxt pid - | itm_2str_ ctxt (Par s) = "Trm "^s; -fun itm_2str t = itm_2str_ (thy2ctxt' "Isac") t; -fun itm2str_ ctxt ((i,is,b,s,itm_):itm) = - "("^(string_of_int i)^" ,"^(ints2str' is)^" ,"^(bool2str b)^" ,"^ - s^" ,"^(itm_2str_ ctxt itm_)^")"; -fun itms2str_ ctxt itms = strs2str' (map (linefeed o (itm2str_ ctxt)) itms); -fun w_itms2str_ ctxt itms = writeln (itms2str_ ctxt itms); - -fun init_item str = SyntaxE str; - - - - -type 'a ppc = - {Given : 'a list, - Where: 'a list, - Find : 'a list, - With : 'a list, - Relate: 'a list}; -fun ppc2str {Given=Given,Where=Where,Find=Find,With=With,Relate=Relate}= - ("{Given =" ^ (strs2str Given ) ^ - ",Where=" ^ (strs2str Where) ^ - ",Find =" ^ (strs2str Find ) ^ - ",With =" ^ (strs2str With ) ^ - ",Relate=" ^ (strs2str Relate) ^ "}"); - - - - -fun item_ppc ({Given = gi,Where= wh, - Find = fi,With = wi,Relate= re}: string ppc) = - {Given = map init_item gi,Where= map init_item wh, - Find = map init_item fi,With = map init_item wi, - Relate= map init_item re}:item ppc; -fun itemppc2str ({Given=Given,Where=Where, - Find=Find,With=With,Relate=Relate}:item ppc)= - ("{Given =" ^ ((strs2str' o (map item2str)) Given ) ^ - ",Where=" ^ ((strs2str' o (map item2str)) Where) ^ - ",Find =" ^ ((strs2str' o (map item2str)) Find ) ^ - ",With =" ^ ((strs2str' o (map item2str)) With ) ^ - ",Relate=" ^ ((strs2str' o (map item2str)) Relate) ^ "}"); - -fun de_item (Correct x) = x - | de_item (SyntaxE x) = x - | de_item (TypeE x) = x - | de_item (False x) = x - | de_item (Incompl x) = x - | de_item (Superfl x) = x - | de_item (Missing x) = x; -val empty_ppc ={Given = [], - Where= [], - Find = [], - With = [], - Relate= []}:item ppc; -val empty_ppc_ct' ={Given = [], - Where = [], - Find = [], - With = [], - Relate= []}:cterm' ppc; - - -datatype match = - Matches of pblID * item ppc -| NoMatch of pblID * item ppc; -fun match2str (Matches (pI, ppc)) = - "Matches ("^(strs2str pI)^", "^(itemppc2str ppc)^")" - | match2str(NoMatch (pI, ppc)) = - "NoMatch ("^(strs2str pI)^", "^(itemppc2str ppc)^")"; -fun matchs2str ms = (strs2str o (map match2str)) ms; -fun pblID_of_match (Matches (pI,_)) = pI - | pblID_of_match (NoMatch (pI,_)) = pI; - -(*10.03 for Refine_Problem*) -datatype match_ = - Match_ of pblID * ((itm list) * ((bool * term) list)) -| NoMatch_; - -(*. the refined pbt is the last_element Matches in the list .*) -fun is_matches (Matches _) = true - | is_matches _ = false; -fun matches_pblID (Matches (pI,_)) = pI; -fun refined ms = ((matches_pblID o the o (find_first is_matches) o rev) ms) - handle _ => []:pblID; -fun refined_IDitms ms = ((find_first is_matches) o rev) ms; - -(*. the refined pbt is the last_element Matches in the list, - for Refine_Problem, tryrefine .*) -fun is_matches_ (Match_ _) = true - | is_matches_ _ = false; -fun refined_ ms = ((find_first is_matches_) o rev) ms; - - -fun ts_in (Cor ((_,ts),_)) = ts - | ts_in (Syn (c)) = [] - | ts_in (Typ (c)) = [] - | ts_in (Inc ((_,ts),_)) = ts - | ts_in (Sup (_,ts)) = ts - | ts_in (Mis _) = []; -(*WN050629 unused*) -fun all_ts_in itm_s = (flat o (map ts_in)) itm_s; -val unique = (term_of o the o (parse (theory "Real"))) "UnIqE_tErM"; -fun d_in (Cor ((d,_),_)) = d - | d_in (Syn (c)) = (writeln("*** d_in: Syn ("^c^")"); unique) - | d_in (Typ (c)) = (writeln("*** d_in: Typ ("^c^")"); unique) - | d_in (Inc ((d,_),_)) = d - | d_in (Sup (d,_)) = d - | d_in (Mis (d,_)) = d; - -fun dts2str (d,ts) = pair2str (term2str d, terms2str ts); -fun penvval_in (Cor ((d,_),(_,ts))) = [comp_ts (d,ts)] - | penvval_in (Syn (c)) = (writeln("*** penvval_in: Syn ("^c^")"); []) - | penvval_in (Typ (c)) = (writeln("*** penvval_in: Typ ("^c^")"); []) - | penvval_in (Inc (_,(_,ts))) = ts - | penvval_in (Sup dts) = (writeln("*** penvval_in: Sup "^(dts2str dts)); []) - | penvval_in (Mis (d,t)) = (writeln("*** penvval_in: Mis "^ - (pair2str(term2str d, term2str t))); []); - - -(*. check a predicate labelled with indication of incomplete substitution; -rls -> (*for eval_true*) -bool * (*have _all_ variables(Free) from the model-pattern - been substituted by a value from the pattern's environment ?*) -term (*the precondition*) --> -bool * (*has the precondition evaluated to true*) -term (*the precondition (for map)*) -.*) -fun evalprecond prls (false, pre) = - (*NOT ALL Free's have been substituted, eg. because of incomplete model*) - (false, pre) - | evalprecond prls (true, pre) = -(* val (prls, pre) = (prls, hd pres'); - val (prls, pre) = (prls, hd (tl pres')); - *) - if eval_true (assoc_thy "Isac.thy") (*for Pattern.match *) - [pre] prls (*pre parsed, prls.thy*) - then (true , pre) - else (false , pre); - -fun pre2str (b, t) = pair2str(bool2str b, term2str t); -fun pres2str pres = strs2str' (map (linefeed o pre2str) pres); - -(*. check preconditions, return true if all true .*) -fun check_preconds' _ [] _ _ = [] (*empty preconditions are true*) - | check_preconds' prls pres pbl _(*FIXME.WN0308 mvat re-introduce*) = -(* val (prls, pres, pbl, _) = (prls, where_, probl, 0); - val (prls, pres, pbl, _) = (prls, pre, itms, mvat); - *) - let val env = mk_env pbl; - val pres' = map (subst_atomic_all env) pres; - in map (evalprecond prls) pres' end; - -fun check_preconds thy prls pres pbl = - check_preconds' prls pres pbl (max_vt pbl); - -(*----------------------------------------------------------*) -end -open SpecifyTools; -(*----------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/ptyps.sml --- a/src/Tools/isac/ME/ptyps.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1279 +0,0 @@ -(* the problems and methods as stored in hierarchies - author Walther Neuper 1998 - (c) due to copyright terms - -use"ME/ptyps.sml"; -use"ptyps.sml"; -*) - -(*-----------------------------------------vvv-(1) aus modspec.sml 23.3.02*) -val dsc_unknown = (term_of o the o (parseold @{theory Script})) - "unknown::'a => unknow"; -(*-----------------------------------------^^^-(1) aus modspec.sml 23.3.02*) - - -(*-----------------------------------------vvv-(2) aus modspec.sml 23.3.02*) - -fun itm_2item thy (Cor ((d,ts),_)) = - Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) - | itm_2item _ (Syn c) = SyntaxE c - | itm_2item _ (Typ c) = TypeE c - | itm_2item thy (Inc ((d,ts),_)) = - Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) - | itm_2item thy (Sup (d,ts)) = - Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts))) - | itm_2item _ (Mis (d,pid)) = - Missing (Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^ - Syntax.string_of_term (thy2ctxt' "Isac") pid); - - -(* --- 8.3.00 -fun get_dsc_in dscppc sel = ((the (assoc (dscppc, sel))):term list) - handle _ => error ("get_dsc_in not for "^sel); - -fun dscs_in dscppc = - ((get_dsc_in dscppc "#Given") @ - (get_dsc_in dscppc "#Find") @ - (get_dsc_in dscppc "#Relate")):term list; - - --- 26.1.88 -fun get_dsc_of pblID sel = (the (assoc((snd o get_pbt) pblID, sel))); -fun get_dsc pblID = - (get_dsc_of pblID "#Given") @ - (get_dsc_of pblID "#Find") @ - (get_dsc_of pblID "#Relate"); - --- *) - -fun mappc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) = - {Given=map f gi, Where=map f wh, - Find=map f fi, With=map f wi, Relate=map f re}:'b ppc; -fun appc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) = - {Given=f gi, Where=f wh, - Find=f fi, With=f wi, Relate=f re}:'b ppc; - -(*for ppc of changing type*) -fun sel_ppc sel ppc = - case sel of - "#Given" => #Given (ppc:'a ppc) - | "#Where" => #Where (ppc:'a ppc) - | "#Find" => #Find (ppc:'a ppc) - | "#With" => #With (ppc:'a ppc) - | "#Relate" => #Relate (ppc:'a ppc) - | _ => raise error ("sel_ppc tried to select by '"^sel^"'"); - -fun repl_sel_ppc sel - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x = - case sel of - "#Given" => ({Given= x,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) - | "#Where" => {Given=gi,Where= x,Find=fi,With=wi,Relate=re} - | "#Find" => {Given=gi,Where=wh,Find= x,With=wi,Relate=re} - | "#With" => {Given=gi,Where=wh,Find=fi,With= x,Relate=re} - | "#Relate" => {Given=gi,Where=wh,Find=fi,With=wi,Relate= x} - | _ => raise error ("repl_sel_ppc tried to select by '"^sel^"'"); - -fun add_sel_ppc thy sel - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x = - case sel of - "#Given" => ({Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) - | "#Where" => {Given=gi,Where=wh@[x],Find=fi,With=wi,Relate=re} - | "#Find" => {Given=gi,Where=wh,Find=fi@[x],With=wi,Relate=re} - | "#Relate"=> {Given=gi,Where=wh,Find=fi,With=wi,Relate=re@[x]} - | "#undef" => {Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}(*ori2itmSup*) - | _ => raise error ("add_sel_ppc tried to select by '"^sel^"'"); -fun add_where ({Given=gi,Find=fi,With=wi,Relate=re,...}:'a ppc) wh = - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc); - -(*-----------------------------------------^^^-(2) aus modspec.sml 23.3.02*) - - -(*-----------------------------------------vvv-(3) aus modspec.sml 23.3.02*) - - - -(*decompose a problem-type into description and identifier - FIXME split_dsc: no term list !!! (just for quick redoing prep_ori) *) -fun split_dsc thy t = - (let val (hd,args) = strip_comb t - in if is_dsc hd - then (hd, args) - else (e_term, [t]) (*??? 9.01 just copied*) - end) - handle _ => raise error ("split_dsc: called with "^ - (Syntax.string_of_term (thy2ctxt' "Isac") t)); -(* -> val t1 = (term_of o the o (parse thy)) "errorBound err_"; -> split_dsc t1; -(Const ("Descript.errorBound","bool => Tools.nam"),Free ("err_","bool")) - : term * term -> val t3 = (term_of o the o (parse thy)) "valuesFor vs_"; -> split_dsc t3; -(Const ("Descript.valuesFor","bool List.list => Tools.toreall"), - Free ("vs_","bool List.list")) : term * term*) - - - -(*. take the first two return-values; for prep_ori .*) -(*WN.13.5.03fun split_dts' thy t = - let val (d, ts, _) = split_dts thy t - in (d, ts) end;*) -(*WN.8.12.03 quick for prep_ori'*) -fun split_dsc' t = - (let val dsc $ var = t - in var end) - handle _ => raise error ("split_dsc': called with "^term2str t); - -(*9.3.00*) -(* split a term into description and (id | structured variable) - for pbt, met.ppc *) -fun split_did t = - (let val (hd,[arg]) = strip_comb t - in (hd,arg) end) - handle _ => raise error ("split_did: doesn't match (hd,[arg]) for t = " - ^(Syntax.string_of_term (thy2ctxt' "Script") t)); - - - -(*create output-string for itm_*) -fun itm_out thy (Cor ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm_out thy (Syn c) = c - | itm_out thy (Typ c) = c - | itm_out thy (Inc ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm_out thy (Sup (d,ts)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm_out thy (Mis (d,pid)) = - Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^ - Syntax.string_of_term (thy2ctxt' "Isac") pid; - -(*22.11.00 unused -fun itm_ppc2str thy ipc = (ppc2str o (mappc (itm__2str thy))) ipc;*) - - -(*--3.3. -fun itms2dts itms = - let - fun coll itms' [] = itms' - | coll itms' (i::itms) = - case i of - (Cor (d,ts)) => coll (itms' @ [(d,ts)]) itms - | (Syn c) => coll (itms' ) itms - | (Typ c) => coll (itms' ) itms - | (Fal (d,ts)) => coll (itms' @ [(d,ts)]) itms - | (Inc (d,ts)) => coll (itms' @ [(d,ts)]) itms - | (Sup (d,ts)) => coll (itms' @ [(d,ts)]) itms - in coll [] itms end; -*) -(*--3.3.00 -fun itm2item ((_,_,_,_,Cor (d,ts)):itm) = - Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm2item (_,_,_,_,Syn (c)) = SyntaxE c - | itm2item (_,_,_,_,Typ (c)) = TypeE c - | itm2item (_,_,_,_,Fal (d,ts)) = - False (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm2item (_,_,_,_,Inc (d,ts)) = - Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))) - | itm2item (_,_,_,_,Sup (d,ts)) = - Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts))); -*) - -fun boolterm2item (true, term) = Correct (term2str term) - | boolterm2item (false, term) = False (term2str term); - -(* use"ME/modspec.sml"; - *) -fun itms2itemppc thy (itms:itm list) (pre:(bool * term) list) = - let - fun coll ppc [] = ppc - | coll ppc ((_,_,_,field,itm_)::itms) = - coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms; - val gfr = coll empty_ppc itms; - in add_where gfr (map boolterm2item pre) end; -(*-----------------------------------------^^^-(3) aus modspec.sml 23.3.02*) - -(*-----------------------------------------vvv-(4) aus modspec.sml 23.3.02*) - -(* --- 9.3.fun add_field dscs (d,ts) = - if d mem (get_dsc_in dscs "#Given") - then ("#Given",d,ts:term list) - else if d mem (get_dsc_in dscs "#Find") - then ("#Find",d,ts) - else if d mem (get_dsc_in dscs "#Relate") - then ("#Relate",d,ts) - else ("#undef",d,ts); -(* 28.1.00 raise error ("add_field: '"^ - (Syntax.string_of_term (thy2ctxt' "Isac") d)^ - "' not in ppc-description "); *) - ------9.3. *) - -(* 9.3.00 - compare d and dsc in pbt and transfer field to pre-ori *) -fun add_field thy pbt (d,ts) = - let fun eq d pt = (d = (fst o snd) pt); - in case filter (eq d) pbt of - [(fi,(dsc,_))] => (fi,d,ts) - | [] => ("#undef",d,ts) (*may come with met.ppc*) - | _ => raise error ("add_field: "^ - (Syntax.string_of_term (thy2ctxt' "Isac") d)^ - " more than once in pbt") - end; - -(*. take over field from met.ppc at 'Specify_Method' into ori, - i.e. also removes "#undef" fields .*) -(* val (mpc, ori) = ((#ppc o get_met) mID, oris); - *) -fun add_field' thy mpc (ori:ori list) = - let fun eq d pt = (d = (fst o snd) pt); - fun repl mpc (i,v,_,d,ts) = - case filter (eq d) mpc of - [(fi,(dsc,_))] => [(i,v,fi,d,ts)] - | [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*) - (*raise error ("add_field': "^ - (Syntax.string_of_term (thy2ctxt' "Isac") d)^ - " not in met"*) - | _ => raise error ("add_field': "^ - (Syntax.string_of_term (thy2ctxt' "Isac") d)^ - " more than once in met"); - in (flat ((map (repl mpc)) ori)):ori list end; - - -(*.mark an element with the position within a plateau; - a plateau with length 1 is marked with 0 .*) -fun mark eq [] = raise error "mark []" - | mark eq xs = - let - fun mar xx eq [x] n = xx @ [(if n=1 then 0 else n,x)] - | mar xx eq (x::x'::xs) n = - if eq(x,x') then mar (xx @ [(n,x)]) eq (x'::xs) (n+1) - else mar (xx @ [(if n=1 then 0 else n,x)]) eq (x'::xs) 1; - in mar [] eq xs 1 end; -(* -> val xs = [1,1,1,2,4,4,5]; -> mark (op=) xs; -val it = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)] -*) - -(*.assumes equal descriptions to be in adjacent 'plateaus', - items at a certain position within the plateaus form a variant; - length = 1 ... marked with 0: covers all variants .*) -fun add_variants fdts = - let - fun eq (a,b) = curry op= (snd3 a) (snd3 b); - in mark eq fdts end; - -(* collect equal elements: the model for coll_variants *) -fun coll eq xs = - let - fun col xs eq x [] = xs @ [x] - | col xs eq x (y::ys) = - if eq(x,y) then col xs eq x ys - else col (xs @ [x]) eq y ys; - in col [] eq (hd xs) xs end; -(* -> val xs = [1,1,1,2,4,4,4]; -> coll (op=) xs; -val it = [1,2,4] : int list -*) - -fun max [] = raise error "max of []" - | max (y::ys) = - let fun mx x [] = x - | mx x (y::ys) = if x < y then mx y ys else mx x ys; -in mx y ys end; -fun gen_max _ [] = raise error "gen_max of []" - | gen_max ord (y::ys) = - let fun mx x [] = x - | mx x (y::ys) = if ord (x, y) then mx y ys else mx x ys; -in mx y ys end; - - - -(* assumes *) -fun coll_variants (((v,x)::vxs)) = - let - fun col xs (vs,x) [] = xs @ [(vs,x)] - | col xs (vs,x) ((v',x')::vxs') = - if x=x' then col xs (vs @ [v'], x') vxs' - else col (xs @ [(vs,x)]) ([v'], x') vxs'; - in col [] ([v],x) vxs end; -(* val xs = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)]; -> col [] ([(fst o hd) xs],(snd o hd) xs) (tl xs); -val it = [([1,2,3],1),([0],2),([1,2],4),([0],5)] *) - - -fun replace_0 vm [0] = intsto vm - | replace_0 vm vs = vs; - -fun add_id [] = raise error "add_id []" - | add_id xs = - let fun add n [] = [] - | add n (x::xs) = (n,x) :: add (n+1) xs; -in add 1 xs end; -(* -> val xs = [([1,2,3],1),([0],2),([1,2],4),([0],5)]; -> add_id xs; -val it = [(1,([#,#,#],1)),(2,([#],2)),(3,([#,#],4)),(4,([#],5))] - *) - -fun flattup (a,(b,(c,d,e))) = (a,b,c,d,e); -fun flattup' (a,(b,((c,d),e))) = (a,b,c,d,e); -fun flat3 (a,(b,c)) = (a,b,c); -(* - val pI = pI'; - !pbts; -*) -(* in root (only!) fmz may be empty: fill with ..,dsc,[] -fun init_ori fmz thy pI = - if fmz <> [] then prep_ori fmz thy pI (*fmz assumed complete*) - else - let - val fds = map (cons2 (fst, fst o snd)) (get_pbt pI); - val vfds = map ((pair [1]) o (rpair [])) fds; - val ivfds = add_id vfds - in (map flattup' ivfds):ori list end; 10.3.00---*) -(* val fmz = ctl; val pI=["sqroot-test","univariate","equation"]; - val (thy,pbt) = (assoc_thy dI',(#ppc o get_pbt) pI'); - val (fmz, thy, pbt) = (fmz, thy, ((#ppc o get_pbt) pI)); - *) -fun prep_ori [] _ _ = [] - | prep_ori fmz thy pbt = - let - val ctopts = map (parse thy) fmz - val _= (*FIXME.WN060916 improve error report*) - if null (filter is_none ctopts) then () - else raise error ("prep_ori: SYNTAX ERROR in " ^ strs2str' fmz) - val dts = map ((split_dts thy) o term_of o the) ctopts - val ori = map (add_field thy pbt) dts; -(* val ori = map (flat3 o (pair "#undef")) dts; *) - val ori' = add_variants ori; - val maxv = max (map fst ori'); - val maxv = if maxv = 0 then 1(*only 1 variant*) else maxv; - val ori'' = coll_variants ori'; - val ori''' = map (apfst (replace_0 maxv)) ori''; - val ori'''' = add_id ori''' - in (map flattup ori''''):ori list end; - - -(*-----------------------------------------^^^-(4) aus modspec.sml 23.3.02*) - -(*.the pattern for an item of a problems model or a methods guard.*) -type pat = (string * (*field*) - (term * (*description*) - term)) (*id | struct-var*); -fun pat2str ((field, (dsc, id)):pat) = - pair2str (field, pair2str (term2str dsc, term2str id)); -fun pats2str pats = (strs2str o (map pat2str)) pats; - -(* data for methods stored in 'methods'-database *) -type met = - {guh : guh, (*unique within this isac-knowledge *) - mathauthors: string list,(*copyright *) - init : pblID, (*WN060721 introduced mistakenly--TODO.REMOVE!*) - rew_ord' : rew_ord', (*for rules in Detail - TODO.WN0509 store fun itself, see 'type pbt'*) - erls : rls, (*the eval_rls for cond. in rules FIXME "rls' - instead erls in "fun prep_met" *) - srls : rls, (*for evaluating list expressions in scr *) - prls : rls, (*for evaluating predicates in modelpattern *) - crls : rls, (*for check_elementwise, ie. formulae in calc.*) - nrls : rls, (*canonical simplifier specific for this met *) - calc : calc list, (*040207: <--- calclist' in fun prep_met *) - (*branch : TransitiveB set in append_problem at generation ob pblobj - FIXXXME.8.03: set branch from met in Apply_Method *) - - (* compare type pbt:*) - ppc: pat list, - (*.items in given, find, relate; - items (in "#Find") which need not occur in the arg-list of a SubProblem - are 'copy-named' with an identifier "*_!_". - copy-named items are 'generating' if they are NOT "*___" - see ME/calchead.sml 'fun is_copy_named'.*) - pre: term list, (*preconditions in where*) - (*script*) - scr: scr (*prep_met requires either script or string "empty_script"*) - }; -(* ------- template ------------------------------------------------------ -store_met - (prep_met *.thy - ([(*"EqSystem","normalize"*)], - [("#Given" ,[ (*"equalities es_", "solveForVars vs_"*)]), - ("#Find" ,[ (*dont forget typing non-reals *)]), - ("#Relate",[])(*may be omitted *) ], - {calc = [], (*filled autom. in prep_met *) - crls = Erls, (*for check_elementwise *) - prls = Erls, (*for evaluating preds in guard *) - nrls = Erls, (*can.simplifier for all formulae*) - rew_ord'="tless_true", (*for rules in Detail *) - rls' = Erls, (*erls, the eval_rls for cond. in rules*) - srls = Erls}, (*for evaluating list expr in scr*) - "empty_script" - )); ----------- template ----------------------------------------------------*) -val e_met = {guh="met_empty",mathauthors=[],init=e_metID, - rew_ord' = "e_rew_ord'": rew_ord', - erls = e_rls, srls = e_rls, prls = e_rls, - calc = [], crls = e_rls, nrls = e_rls, - (*asm_thm = []: thm' list, - asm_rls = []: rls' list,*) - ppc = []: (string * (term * term)) list, - pre = []: term list, - scr = EmptyScr: scr}:met; - - -(** problem-types stored in format for usage in specify **) -(*25.8.01 ---- -val pbltypes = ref ([(e_pblID,[])]:(pblID * ((string * (* field "#Given",..*) - (term * (* description *) - term)) (* id | struct-var *) - list) - ) list);*) - -(*deprecated due to 'type pat'*) -type pbt_ = (string * (* field "#Given",..*) - (term * (* description *) - term)); (* id | struct-var *) -val e_pbt_ = ("#Undef", (e_term, e_term)):pbt_; -type pbt = - {guh : guh, (*unique within this isac-knowledge*) - mathauthors: string list, (*copyright*) - init : pblID, (*to start refinement with*) - thy : theory, (* which allows to compile that pbt - TODO: search generalized for subthy (ref.p.69*) - (*^^^ WN050912 NOT used during application of the problem, - because applied terms may be from 'subthy' as well as from super; - thus we take 'maxthy'; see match_ags !*) - cas : term option,(*'CAS-command'*) - prls : rls, (* for preds in where_*) - where_: term list, (* where - predicates*) - ppc : pat list, - (*this is the model-pattern; - it contains "#Given","#Where","#Find","#Relate"-patterns*) - met : metID list}; (* methods solving the pbt*) -val e_pbt = {guh="pbl_empty",mathauthors=[],init=e_pblID,thy=theory "Pure", - cas=NONE,prls=Erls,where_=[],ppc=[],met=[]}:pbt; -fun pbt2 (str, (t1, t2)) = - pair2str (str, pair2str (term2str t1, term2str t2)); -fun pbt2str pbt = (strs2str o (map (linefeed o pbt2))) pbt; - - -val e_Ptyp = Ptyp ("e_pblID",[e_pbt],[]); -val e_Mets = Ptyp ("e_metID",[e_met],[]); - -type ptyps = (pbt ptyp) list; -val ptyps = ref ([e_Ptyp]:ptyps); - -type mets = (met ptyp) list; -val mets = ref ([e_Mets]:mets); - - -(**+ breadth-first search on hierarchy of problem-types +**) - -type pblRD = pblID;(*pblID are Reverted _on calling_ the retrieve-funs*) - (* eg. ["equations","univariate","normalize"] while - ["normalize","univariate","equations"] is the related pblID - WN.24.4.03: also used for metID*) - -fun get_py thy d _ [] = - error ("get_pbt not found: "^(strs2str d)) - | get_py thy d [k] ((Ptyp (k',[py],_))::pys) = - if k=k' then py - else get_py thy d ([k]:pblRD) pys - | get_py thy d (k::ks) ((Ptyp (k',_,pys))::pys') = - if k=k' then get_py thy d ks pys - else get_py thy d (k::ks) pys'; -(*> ptyps:= -[Ptyp ("1",[("ptyp 1",([],[]))], - [Ptyp ("11",[("ptyp 11",([],[]))], - []) - ]), - Ptyp ("2",[("ptyp 2",([],[]))], - [Ptyp ("21",[("ptyp 21",([],[]))], - []) - ]) - ]; -> get_py SqRoot.thy ["1"] ["1"] (!ptyps); -> get_py SqRoot.thy ["2","21"] ["2","21"] (!ptyps); - _REVERSE_ .......... !!!!!!!!!!*) - -(*TODO: search generalized for subthy*) -fun get_pbt (pblID:pblID) = - let val pblRD = rev pblID; - in get_py (theory "Pure") pblID pblRD (!ptyps) end; -(* get_pbt thy ["1"]; - get_pbt thy ["21","2"]; - *) - -(*TODO: throws exn 'get_pbt not found: ' ... confusing !! - take 'ketype' as an argument !!!!!*) -fun get_met (metID:metID) = get_py (theory "Pure") metID metID (!mets); -fun get_the (theID:theID) = get_py (theory "Pure") theID theID (!thehier); - - - -fun del_eq k ptyps = -let fun del k ptyps [] = ptyps - | del k ptyps ((Ptyp (k', [p], ps))::pys) = - if k=k' then del k ptyps pys - else del k (ptyps @ [Ptyp (k', [p], ps)]) pys; -in del k [] ptyps end; - -fun insrt d pbt [k] [] = [Ptyp (k, [pbt],[])] - - | insrt d pbt [k] ((Ptyp (k', [p], ps))::pys) = -((*writeln("### insert 1: ks = "^(strs2str [k])^" k'= "^k');*) - if k=k' - then ((Ptyp (k', [pbt], ps))::pys) - else (*ev.newly added pbt is free _only_ with 'last_elem pblID'*) - ((Ptyp (k', [p], ps))::(insrt d pbt [k] pys)) -) - | insrt d pbt (k::ks) ((Ptyp (k', [p], ps))::pys) = -((*writeln("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*) - if k=k' - then ((Ptyp (k', [p], insrt d pbt ks ps))::pys) - else - if length pys = 0 - then error ("insert: not found "^(strs2str (d:pblID))) - else ((Ptyp (k', [p], ps))::(insrt d pbt (k::ks) pys)) -); - - -fun coll_pblguhs pbls = - let fun node coll (Ptyp (_,[n],ns)) = - [(#guh : pbt -> guh) n] @ (nodes coll ns) - and nodes coll [] = coll - | nodes coll (n::ns) = (node coll n) @ (nodes coll ns); - in nodes [] pbls end; -fun coll_metguhs mets = - let fun node coll (Ptyp (_,[n],ns)) = - [(#guh : met -> guh) n] - and nodes coll [] = coll - | nodes coll (n::ns) = (node coll n) @ (nodes coll ns); - in nodes [] mets end; - -(*.lookup a guh in hierarchy or methods depending on fst chars in guh.*) -fun guh2kestoreID (guh:guh) = - case (implode o (take_fromto 1 4) o explode) guh of - "pbl_" => - let fun node ids gu (Ptyp (id,[n as {guh,...} : pbt], ns)) = - if gu = guh - then SOME ((ids@[id]) : kestoreID) - else nodes (ids@[id]) gu ns - and nodes _ _ [] = NONE - | nodes ids gu (n::ns) = - case node ids gu n of SOME id => SOME id - | NONE => nodes ids gu ns - in case nodes [] guh (!ptyps) of - SOME id => rev id - | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^ - "not found in (!ptyps)") - end - | "met_" => - let fun node ids gu (Ptyp (id,[n as {guh,...} : met], ns)) = - if gu = guh - then SOME ((ids@[id]) : kestoreID) - else nodes (ids@[id]) gu ns - and nodes _ _ [] = NONE - | nodes ids gu (n::ns) = - case node ids gu n of SOME id => SOME id - | NONE => nodes ids gu ns - in case nodes [] guh (!mets) of - SOME id => id - | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^ - "not found in (!mets)") end - | _ => error ("guh2kestoreID called with '" ^ guh ^ "'"); -(*> guh2kestoreID "pbl_equ_univ_lin"; -val it = ["linear", "univariate", "equation"] : string list*) - - -fun check_pblguh_unique (guh:guh) (pbls: (pbt ptyp) list) = - if member op = (coll_pblguhs pbls) guh - then error ("check_guh_unique failed with '"^guh^"';\n"^ - "use 'sort_pblguhs()' for a list of guhs;\n"^ - "consider setting 'check_guhs_unique := false'") - else (); -(* val (guh, mets) = ("met_test", !mets); - *) -fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) = - if member op = (coll_metguhs mets) guh - then error ("check_guh_unique failed with '"^guh^"';\n"^ - "use 'sort_metguhs()' for a list of guhs;\n"^ - "consider setting 'check_guhs_unique := false'") - else (); - - - -(*.the pblID has the leaf-element as first; better readability achieved;.*) -fun store_pbt (pbt as {guh,...}, pblID) = - (if (!check_guhs_unique) then check_pblguh_unique guh (!ptyps) else (); - ptyps:= insrt pblID pbt (rev pblID) (!ptyps)); - -(*.the metID has the root-element as first; compare 'fun store_pbt'.*) -(* val (met as {guh,...}, metID) = - ((prep_met EqSystem.thy "met_eqsys" [] e_metID - (["EqSystem"], - [], - {rew_ord'="tless_true", rls' = Erls, calc = [], - srls = Erls, prls = Erls, crls = Erls, nrls = Erls}, - "empty_script" - ))); - *) -fun store_met (met as {guh,...}, metID) = - (if (!check_guhs_unique) then check_metguh_unique guh (!mets) else (); - mets:= insrt metID met metID (!mets)); - - -(*. prepare problem-types before storing in pbltypes; - dont forget to 'check_guh_unique' before ins.*) -fun prep_pbt thy guh maa init - (pblID, dsc_dats: (string * (string list)) list, - ev:rls, ca: string option, metIDs:metID list) = -(* val (thy, (pblID, dsc_dats: (string * (string list)) list, - ev:rls, ca: string option, metIDs:metID list)) = - ((EqSystem.thy, (["system"], - [("#Given" ,["equalities es_", "solveForVars vs_"]), - ("#Find" ,["solution ss___"](*___ is copy-named*)) - ], - append_rls "e_rls" e_rls [(*for preds in where_*)], - SOME "solveSystem es_ vs_", - []))); - *) - let fun eq f (f', _) = f = f'; - val gi = filter (eq "#Given") dsc_dats; -(*val gi = [("#Given",["equality e_","solveFor v_"])] - : (string * string list) list*) - val gi = (case gi of - [] => [] - | ((_,gi')::[]) => - ((map (split_did o term_of o the o (parse thy)) gi') - handle _ => error - ("prep_pbt: syntax error in '#Given' of "^ - (strs2str pblID))) - | _ => - (error ("prep_pbt: more than one '#Given' in "^ - (strs2str pblID)))); -(*val gi = - [(Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool")), - (Const ("Descript.solveFor","RealDef.real => Tools.una"), - Free ("v_","RealDef.real"))] : (term * term) list *) - val gi = map (pair "#Given") gi; -(*val gi = - [("#Given", - (Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool"))), - ("#Given", - (Const ("Descript.solveFor","RealDef.real => Tools.una"), - Free ("v_","RealDef.real")))] : (string * (term * term)) list*) - - val fi = filter (eq "#Find") dsc_dats; - val fi = (case fi of - [] => [](*28.8.01: ["tool"] ...// raise error - ("prep_pbt: no '#Find' in "^(strs2str pblID))*) -(* val ((_,fi')::[]) = fi; - *) - | ((_,fi')::[]) => - ((map (split_did o term_of o the o (parse thy)) fi') - handle _ => raise error - ("prep_pbt: syntax error in '#Find' of "^ - (strs2str pblID))) - | _ => - (raise error ("prep_pbt: more than one '#Find' in "^ - (strs2str pblID)))); - val fi = map (pair "#Find") fi; - - val re = filter (eq "#Relate") dsc_dats; - val re = (case re of - [] => [] - | ((_,re')::[]) => - ((map (split_did o term_of o the o (parse thy)) re') - handle _ => raise error - ("prep_pbt: syntax error in '#Relate' of "^ - (strs2str pblID))) - | _ => - (raise error ("prep_pbt: more than one '#Relate' in "^ - (strs2str pblID)))); - val re = map (pair "#Relate") re; - - val wh = filter (eq "#Where") dsc_dats; - val wh = (case wh of - [] => [] - | ((_,wh')::[]) => - ((map (term_of o the o (parse thy)) wh') - handle _ => raise error - ("prep_pbt: syntax error in '#Where' of "^ - (strs2str pblID))) - | _ => - (raise error ("prep_pbt: more than one '#Where' in "^ - (strs2str pblID)))); - in ({guh=guh,mathauthors=maa,init=init, - thy=thy,cas= case ca of NONE => NONE - | SOME s => - SOME ((term_of o the o (parse thy)) s), - prls=ev,where_=wh,ppc= gi @ fi @ re, - met=metIDs}, pblID):pbt * pblID end; -(* prep_pbt thy (pblID, dsc_dats, metIDs); - val it = - ({met=[], - ppc=[("#Given",(Const (#,#),Free (#,#))), - ("#Given",(Const (#,#),Free (#,#))), - ("#Find",(Const (#,#),Free (#,#)))], - thy={ProtoPure, ..., Atools, RatArith}, - where_=[Const ("Descript.solutions","bool List.list => Tools.toreall") $ - Free ("v_i_","bool List.list")]},["equation"]) : pbt * pblID *) - - - - -(*. prepare met for storage analogous to pbt .*) -fun prep_met thy guh maa init - (metID, ppc: (string * string list) list (*'#Where' -> #pre*), - {rew_ord'=ro, rls'=rls, srls=srls, prls=prls, - calc = scr_isa_fns(*FIXME.040207: del - auto-done*), - crls=cr, nrls=nr}, scr) = - let fun eq f (f', _) = f = f'; - (*val thy = (assoc_thy o fst) metID*) - val gi = filter (eq "#Given") ppc; - val gi = (case gi of - [] => [] - | ((_,gi')::[]) => - ((map (split_did o term_of o the o (parse thy)) gi') - handle _ => raise error - ("prep_pbt: syntax error in '#Given' of "^ - (strs2str metID))) - | _ => - (raise error ("prep_pbt: more than one '#Given' in "^ - (strs2str metID)))); - val gi = map (pair "#Given") gi; - - val fi = filter (eq "#Find") ppc; - val fi = (case fi of - [] => [](*28.8.01: ["tool"] ...// raise error - ("prep_pbt: no '#Find' in "^(strs2str metID))*) - | ((_,fi')::[]) => - ((map (split_did o term_of o the o (parse thy)) fi') - handle _ => raise error - ("prep_pbt: syntax error in '#Find' of "^ - (strs2str metID))) - | _ => - (raise error ("prep_pbt: more than one '#Find' in "^ - (strs2str metID)))); - val fi = map (pair "#Find") fi; - - val re = filter (eq "#Relate") ppc; - val re = (case re of - [] => [] - | ((_,re')::[]) => - ((map (split_did o term_of o the o (parse thy)) re') - handle _ => raise error - ("prep_pbt: syntax error in '#Relate' of "^ - (strs2str metID))) - | _ => - (raise error ("prep_pbt: more than one '#Relate' in "^ - (strs2str metID)))); - val re = map (pair "#Relate") re; - - val wh = filter (eq "#Where") ppc; - val wh = (case wh of - [] => [] - | ((_,wh')::[]) => - ((map (term_of o the o (parse thy)) wh') - handle _ => raise error - ("prep_pbt: syntax error in '#Where' of "^ - (strs2str metID))) - | _ => - (raise error ("prep_pbt: more than one '#Where' in "^ - (strs2str metID)))); - val sc = (((inst_abs thy) o term_of o the o (parse thy)) scr) - in ({guh=guh,mathauthors=maa,init=init, - ppc=gi@fi@re, pre=wh, rew_ord'=ro, erls=rls, srls=srls, prls=prls, - calc = if scr = "empty_script" then [] - else ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o - (filter is_calc) o stacpbls) sc, - crls=cr, nrls=nr, scr=Script sc}:met, - metID:metID) - end; - - -(**. get pblIDs of all entries in mat3D .**) - - -fun format_pblID strl = enclose " [" "]" (commas_quote strl); -fun format_pblIDl strll = enclose "[\n" "\n]\n" - (space_implode ",\n" (map format_pblID strll)); - -fun scan _ [] = [] (* no base case, for empty doms only *) - | scan id ((Ptyp ((i,_,[])))::[]) = [id@[i]] - | scan id ((Ptyp ((i,_,pl)))::[]) = scan (id@[i]) pl - | scan id ((Ptyp ((i,_,[])))::ps) = [id@[i]] @(scan id ps) - | scan id ((Ptyp ((i,_,pl)))::ps) =(scan (id@[i]) pl)@(scan id ps); - -fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (!ptyps); -(* ptyps:=[]; - show_ptyps(); - *) -fun show_mets () = (writeln o format_pblIDl o (scan [])) (!mets); - - - -(*vvvvv---------- preparational work 8.01. UNUSED *) -(**+ instantiate a problem-type +**) - -(*+ transform oris +*) - -fun coll_vats (vats, ((_,vs,_,_,_):ori)) = union op = vats vs; -(*> coll_vats [11,22] (hd oris); -val it = [22,11,1,2,3] : int list - -> foldl coll_vats ([],oris); -val it = [1,2,3] : int list - -> val i=1; -> filter ((curry (op mem) i) o #2) oris; -val it = - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), - (2,[1,2,3],"#Find",Const (#,#),[Free #]), - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), - (6,[1],"#undef",Const (#,#),[Free #]), - (9,[1,2],"#undef",Const (#,#),[# $ #]), - (11,[1,2,3],"#undef",Const (#,#),[# $ #])] : ori list *) - -local infix mem; (*from Isabelle2002*) -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun filter_vat oris i = - filter ((curry (op mem) i) o (#2 : ori -> int list)) oris; -end; -(*> map (filter_vat oris) [1,2,3]; -val it = - [[(1,[1,2,3],"#Given",Const (#,#),[# $ #]), - (2,[1,2,3],"#Find",Const (#,#),[Free #]), - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), - (6,[1],"#undef",Const (#,#),[Free #]), - (9,[1,2],"#undef",Const (#,#),[# $ #]), - (11,[1,2,3],"#undef",Const (#,#),[# $ #])], - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), - (2,[1,2,3],"#Find",Const (#,#),[Free #]), - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]), - (7,[2],"#undef",Const (#,#),[Free #]), - (9,[1,2],"#undef",Const (#,#),[# $ #]), - (11,[1,2,3],"#undef",Const (#,#),[# $ #])], - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]), - (2,[1,2,3],"#Find",Const (#,#),[Free #]), - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]), - (5,[3],"#Relate",Const (#,#),[# $ #,# $ #,# $ #]), - (8,[3],"#undef",Const (#,#),[Free #]), - (10,[3],"#undef",Const (#,#),[# $ #]), - (11,[1,2,3],"#undef",Const (#,#),[# $ #])]] : ori list list*) - -fun separate_vats oris = - let val vats = foldl coll_vats ([] : int list, oris); - in map (filter_vat oris) vats end; -(*^^^ end preparational work 8.01.*) - - - -(**. check a problem (ie. itm list) for matching a problemtype .**) - -fun eq1 d (_,(d',_)) = (d = d'); -fun itm_id ((i,_,_,_,_):itm) = i; -fun ori_id ((i,_,_,_,_):ori) = i; -fun ori2itmSup ((i,v,_,d,ts):ori) = ((i,v,true,"#Given",Sup(d,ts)):itm); -(*see + add_sel_ppc ~~~~~~~*) -fun field_eq f ((_,_,f',_,_):ori) = f = f'; - -(*. check an item (with arbitrary itm_ from previous matchings) - for matching a problemtype; returns true only for itms found in pbt .*) -fun chk_ thy pbt ((i,vats,b,f,Cor ((d,vs),_)):itm) = - (case find_first (eq1 d) pbt of - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), - (id, pbl_ids' thy d vs))):itm) - | NONE => (i,vats,false,f,Sup (d,vs))) - | chk_ thy pbt ((i,vats,b,f,Inc ((d,vs),_)):itm) = - (case find_first (eq1 d) pbt of - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), - (id, pbl_ids' thy d vs))):itm) - | NONE => (i,vats,false,f,Sup (d,vs))) - - | chk_ thy pbt (itm as (i,vats,b,f,Syn ct):itm) = itm - | chk_ thy pbt (itm as (i,vats,b,f,Typ ct):itm) = itm - - | chk_ thy pbt ((i,vats,b,f,Sup (d,vs)):itm) = - (case find_first (eq1 d) pbt of - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs), - (id, pbl_ids' thy d vs))):itm) - | NONE => (i,vats,false,f,Sup (d,vs))) -(* val (i,vats,b,f,Mis (d,vs)) = i4; - *) - | chk_ thy pbt ((i,vats,b,f,Mis (d,vs)):itm) = - (case find_first (eq1 d) pbt of -(* val SOME (_,(_,id)) = find_first (eq1 d) pbt; - *) - SOME (_,(_,id)) => raise error "chk_: ((i,vats,b,f,Cor ((d,vs),\ - \(id, pbl_ids' d vs))):itm)" - | NONE => (i,vats,false,f,Sup (d,[vs]))); - -(* chk_ thy pbt i - *) - -fun eq2 (_,(d,_)) ((_,_,_,_,itm_):itm) = d = d_in itm_; -fun eq2' (_,(d,_)) ((_,_,_,d',_):ori) = d = d'; -fun eq0 ((0,_,_,_,_):itm) = true - | eq0 _ = false; -fun max_i i [] = i - | max_i i ((id,_,_,_,_)::is) = - if i > id then max_i i is else max_i id is; -fun max_id [] = 0 - | max_id ((id,_,_,_,_)::is) = max_i id is; -fun add_idvat itms _ _ [] = itms - | add_idvat itms i mvat (((_,_,b,f,itm_):itm)::its) = - add_idvat (itms @ [(i,[(*mvat ...meaningless with pbl-identifier *) - ],b,f,itm_):itm]) (i+1) mvat its; - - -(*. find elements of pbt not contained in itms; - if such one is untouched, return this one, otherwise create new itm .*) -fun chk_m (itms:itm list) untouched (p as (f,(d,id))) = - case find_first (eq2 p) itms of - SOME _ => [] - | NONE => (case find_first (eq2 p) untouched of - SOME itm => [itm] - | NONE => [(0,[],false,f,Mis (d,id)):itm]); -(* val itms = itms''; - *) -fun chk_mis mvat itms untouched pbt = - let val mis = (flat o (map (chk_m itms untouched))) pbt; - val mid = max_id itms; - in add_idvat [] (mid + 1) mvat mis end; - -(*. check a problem (ie. itm list) for matching a problemtype, - takes the max_vt for concluding completeness (could be another!) .*) -(* val itms = itms'; val (pbt,pre) = (ppc, pre); - val itms = itms; val (pbt,pre) = (ppc, pre); - *) -fun match_itms thy itms (pbt,pre,prls) = - (let fun okv mvat (_,vats,b,_,_) = member op = vats mvat - andalso b; - val itms' = map (chk_ thy pbt) itms; (*all found are #3 true*) - val mvat = max_vt itms'; - val itms'' = filter (okv mvat) itms'; - val untouched = filter eq0 itms;(*i.e. dsc only (from init)*) - val mis = chk_mis mvat itms'' untouched pbt; - val pre' = check_preconds' prls pre itms'' mvat - val pb = foldl and_ (true, map fst pre') - in (length mis = 0 andalso pb, (itms'@ mis, pre')) end); - -(*. check a problem pbl (ie. itm list) for matching a problemtype pbt, - for missing items get data from formalization (ie. ori list); - takes the max_vt for concluding completeness (could be another!) .*) -(* (0) determine the most frequent variant mv in pbl - ALL pbt. (1) dsc(pbt) notmem dsc(pbls) => - (2) filter (dsc(pbt) = dsc(oris)) oris; -> news; - (3) newitms = filter (mv mem vat(news)) news - (4) pbt @ newitms *) -(* val (pbl, pbt, pre) = (met, mtt, pre); - val (pbl, pbt, pre) = (itms, #ppc pbt, #where_ pbt); - val (pbl, pbt, pre) = (itms, ppc, where_); - *) -fun match_itms_oris thy (pbl:itm list) (pbt, pre, prls) oris = - let - (*0*)val mv = max_vt pbl; - - fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_; - fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of - SOME _ => false | NONE => true; - (*1*)val mis = (*(map (cons2 (fst, fst o snd)))o*) (filter (notmem pbl)) pbt; - - fun eqdsc_ori (_,(d,_)) ((_,_,_,d',_):ori) = d = d'; - fun ori2itmMis (f,(d,pid)) ((i,v,_,_,ts):ori) = - (i,v,false,f,Mis (d,pid)):itm; - (*2*)fun oris2itms oris mis1 = - ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris; - val news = (flat o (map (oris2itms oris))) mis; - (*3*)fun mem_vat (_,vats,b,_,_) = member op = vats mv; - val newitms = filter mem_vat news; - (*4*)val itms' = pbl @ newitms; - val pre' = check_preconds' prls pre itms' mv - val pb = foldl and_ (true, map fst pre') - in (length mis = 0 andalso pb, (itms', pre')) end; - (*handle _ => (false,([],[]))*); - - -(*vvv--- doubled 20.9.01: ... 7.3.02 itms --> oris, because oris - allow for faster access to descriptions and terms *) -(**. check a problem (ie. itm list) for matching a problemtype .**) - -(*. check an ori for matching a problemtype by description; - returns true only for itms found in pbt .*) -fun chk1_ thy pbt ((i,vats,f,d,vs):ori) = - case find_first (eq1 d) pbt of - SOME (_,(_,id)) => [(i,vats,true,f, - Cor ((d,vs), (id, pbl_ids' thy d vs))):itm] - | NONE => []; - -(* elem 'p' of pbt contained in itms ? *) -fun chk1_m (itms:itm list) p = - case find_first (eq2 p) itms of - SOME _ => true | NONE => false; -fun chk1_m' (oris: ori list) (p as (f,(d,t))) = - case find_first (eq2' p) oris of - SOME _ => [] - | NONE => [(f, Mis (d, t))]; -fun pair0vatsfalse (f,itm_) = (0,[],false,f,itm_):itm; - -fun chk1_mis mvat itms ppc = foldl and_ (true, map (chk1_m itms) ppc); -fun chk1_mis' oris ppc = - map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc); - - -(*. check a problem (ie. ori list) for matching a problemtype, - takes the max_vt for concluding completeness (FIXME could be another!) .*) -(* val (prls,oris,pbt,pre)=(#prls py, ori, #ppc py, #where_ py); - *) -fun match_oris thy prls oris (pbt,pre) = - let val itms = (flat o (map (chk1_ thy pbt))) oris; - val mvat = max_vt itms; - val complete = chk1_mis mvat itms pbt; - val pre' = check_preconds' prls pre itms mvat - val pb = foldl and_ (true, map fst pre') - in if complete andalso pb then true else false end; -(*run subp-rooteq.sml 'root-eq + subpbl: solve_linear' - until 'val nxt = ("Model_Problem",Model_Problem ["linear","univariate"... -> val Nd(PblObj _,[_,_,_,_,_,_,_,_,_,_,_, - Nd(PblObj{origin=(oris,_,_),...},[])]) = pt; -> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"], - (#where_ o get_pbt) ["linear","univariate","equation"]); -> match_oris oris (pbt,pre); -val it = true : bool - - -> val (pbt,pre) =((#ppc o get_pbt) ["plain_square","univariate","equation"], - (#where_ o get_pbt)["plain_square","univariate","equation"]); -> match_oris oris (pbt,pre); -val it = false : bool - - - --------------------------------------------------- - run subp-rooteq.sml 'root-eq + subpbl: solve_plain_square' - until 'val nxt = ("Model_Problem",Model_Problem ["plain_square","univ... -> val Nd (PblObj _, [_,_,_,_,_,_,_,Nd (PrfObj _,[]), - Nd (PblObj {origin=(oris,_,_),...},[])]) = pt; -> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"], - (#where_ o get_pbt) ["linear","univariate","equation"]); -> match_oris oris (pbt,pre); -val it = false : bool - - -> val (pbt,pre)=((#ppc o get_pbt) ["plain_square","univariate","equation"], - (#where_ o get_pbt) ["plain_square","univariate","equation"]); -> match_oris oris (pbt,pre); -val it = true : bool -*) -(*^^^--- doubled 20.9.01 *) - - -(*. check a problem (ie. ori list) for matching a problemtype, - returns items for output to math-experts .*) -(* val (ppc,pre) = (#ppc py, #where_ py); - *) -fun match_oris' thy oris (ppc,pre,prls) = -(* val (thy, oris, (ppc,pre,prls)) = (thy, oris, (ppc, where_, prls)); - *) - let val itms = (flat o (map (chk1_ thy ppc))) oris; - val sups = ((map ori2itmSup) o (filter(field_eq "#undef")))oris; - val mvat = max_vt itms; - val miss = chk1_mis' oris ppc; - val pre' = check_preconds' prls pre itms mvat - val pb = foldl and_ (true, map fst pre') - in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end; - -(*. for the user .*) -datatype match' = - Matches' of item ppc -| NoMatch' of item ppc; - -(*. match a formalization with a problem type .*) -fun match_pbl (fmz:fmz_) ({thy=thy,where_=pre,ppc,prls=er,...}:pbt) = - let val oris = prep_ori fmz thy ppc; - val (bool, (itms, pre')) = match_oris' thy oris (ppc,pre,er); - in if bool then Matches' (itms2itemppc thy itms pre') - else NoMatch' (itms2itemppc thy itms pre') end; -(* -val fmz = ["equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))", - "solveFor x","errorBound (eps=0)","solutions L"]; -val pbt as {thy = thy, where_ = pre, ppc = ppc,...} = - get_pbt ["univariate","equation"]; -match_pbl fmz pbt; -*) - - -(*. refine a problem; construct pblRD while scanning .*) -(* val (pblRD,ori)=("xxx",oris); - val py = get_pbt ["equation"]; - val py = get_pbt ["univariate","equation"]; - val py = get_pbt ["linear","univariate","equation"]; - val py = get_pbt ["root","univariate","equation"]; - match_oris (#prls py) ori (#ppc py, #where_ py); - - *) -fun refin (pblRD:pblRD) ori -((Ptyp (pI,[py],[])):pbt ptyp) = - if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) - then SOME ((pblRD @ [pI]):pblRD) - else NONE - | refin pblRD ori (Ptyp (pI,[py],pys)) = - if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) - then (case refins (pblRD @ [pI]) ori pys of - SOME pblRD' => SOME pblRD' - | NONE => SOME (pblRD @ [pI])) - else NONE -and refins pblRD ori [] = NONE - | refins pblRD ori ((p as Ptyp (pI,_,_))::pts) = - (case refin pblRD ori p of - SOME pblRD' => SOME pblRD' - | NONE => refins pblRD ori pts); - -(*. refine a problem; version providing output for math-experts .*) -fun refin' (pblRD:pblRD) fmz pbls ((Ptyp (pI,[py],[])):pbt ptyp) = -(* val ((pblRD:pblRD), fmz, pbls, ((Ptyp (pI,[py],[])):pbt ptyp)) = - (rev ["linear","system"], fmz, [(*match list*)], - ((Ptyp ("2x2",[get_pbt ["2x2","linear","system"]],[])):pbt ptyp)); - *) - let val _ = (writeln o ((curry op^)"*** pass ") o strs2str)(pblRD @ [pI]) - val {thy,ppc,where_,prls,...} = py - val oris = prep_ori fmz thy ppc - (*8.3.02: itms!: oris ev. are _not_ complete here*) - val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls) - in if b then pbls @ [Matches (rev (pblRD @ [pI]), - itms2itemppc thy itms pre')] - else pbls @ [NoMatch (rev (pblRD @ [pI]), - itms2itemppc thy itms pre')] - end -(* val pblRD = ["pbla"]; val fmz = fmz1; val pbls = []; - val Ptyp (pI,[py],pys) = hd (!ptyps); - refin' pblRD fmz pbls (Ptyp (pI,[py],pys)); -*) - | refin' pblRD fmz pbls (Ptyp (pI,[py],pys)) = - let val _ = (writeln o ((curry op^)"*** pass ") o strs2str) (pblRD @ [pI]) - val {thy,ppc,where_,prls,...} = py - val oris = prep_ori fmz thy ppc; - (*8.3.02: itms!: oris ev. are _not_ complete here*) - val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls); - in if b - then let val pbl = Matches (rev (pblRD @ [pI]), - itms2itemppc thy itms pre') - in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end - else (pbls @ [NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')]) - end -and refins' pblRD fmz pbls [] = pbls - | refins' pblRD fmz pbls ((p as Ptyp (pI,_,_))::pts) = - let val pbls' = refin' pblRD fmz pbls p - in case last_elem pbls' of - Matches _ => pbls' - | NoMatch _ => refins' pblRD fmz pbls' pts end; - -(*. refine a problem; version for tactic Refine_Problem .*) -fun refin'' thy (pblRD:pblRD) itms pbls ((Ptyp (pI,[py],[])):pbt ptyp) = - let (*val _ = writeln("### refin''1: pI="^pI);*) - val {thy,ppc,where_,prls,...} = py - val (b, (itms', pre')) = match_itms thy itms (ppc,where_,prls); - in if b then pbls @ [Match_ (rev (pblRD @ [pI]), (itms', pre'))] - else pbls @ [NoMatch_] - end -(* val pblRD = (rev o tl) pblID; val pbls = []; - val Ptyp (pI,[py],pys) = app_ptyp I pblID (rev pblID) (!ptyps); - *) - | refin'' thy pblRD itms pbls (Ptyp (pI,[py],pys)) = - let (*val _ = writeln("### refin''2: pI="^pI);*) - val {thy,ppc,where_,prls,...} = py - val(b, (itms', pre')) = match_itms thy itms (ppc,where_,prls); - in if b - then let val pbl = Match_ (rev (pblRD @ [pI]), (itms', pre')) - in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end - else (pbls @ [NoMatch_]) - end -and refins'' thy pblRD itms pbls [] = pbls - | refins'' thy pblRD itms pbls ((p as Ptyp (pI,_,_))::pts) = - let val pbls' = refin'' thy pblRD itms pbls p - in case last_elem pbls' of - Match_ _ => pbls' - | NoMatch_ => refins'' thy pblRD itms pbls' pts end; - - -(*. apply a fun to a ptyps node; copied from get_py .*) -fun app_ptyp f (d:pblID) _ [] = - raise error ("app_ptyp not found: "^(strs2str d)) - | app_ptyp f d (k::[]) ((p as Ptyp (k',[py],_))::pys) = - if k=k' then f p - else app_ptyp f d ([k]:pblRD) pys - | app_ptyp f d (k::ks) ((Ptyp (k',_,pys))::pys') = - if k=k' then app_ptyp f d ks pys - else app_ptyp f d (k::ks) pys'; - -(*. for tactic Refine_Tacitly .*) -(*!!! oris are already created wrt. some pbt; pbt contains thy for parsing*) -(* val (thy,pblID) = (assoc_thy dI',pI); - *) -fun refine_ori oris (pblID:pblID) = - let val opt = app_ptyp (refin ((rev o tl) pblID) oris) - pblID (rev pblID) (!ptyps); - in case opt of - SOME pblRD => let val (pblID':pblID) =(rev pblRD) - in if pblID' = pblID then NONE - else SOME pblID' end - | NONE => NONE end; -fun refine_ori' oris pI = (the (refine_ori oris pI)) handle _ => pI; - -(*. for tactic Refine_Problem .*); -(* 10.03: returnvalue -> (pIrefined, itm list) would be sufficient *) -(* val pblID = pI; app_ptyp I pblID (rev pblID) (!ptyps); - *) -fun refine_pbl thy (pblID:pblID) itms = - case refined_ (app_ptyp (refin'' thy ((rev o tl) pblID) itms []) - pblID (rev pblID) (!ptyps)) of - NONE => NONE - | SOME (Match_ (rfd as (pI',_))) => - if pblID = pI' then NONE else SOME rfd; - - -(*. for math-experts .*) -(*19.10.02FIXME: needs thy for parsing fmz*) -(* val fmz = fmz1; val pblID = ["pbla"]; val pblRD = (rev o tl) pblID; - val pbls = []; val ptys = !ptyps; - *) -fun refine (fmz:fmz_) (pblID:pblID) = - app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID) (!ptyps); - - -(*.make a guh from a reference to an element in the kestore; - EXCEPT theory hierarchy ... compare 'fun keref2xml'.*) -fun pblID2guh (pblID:pblID) = - (((#guh o get_pbt) pblID) - handle _ => raise error ("pblID2guh: not for '"^strs2str' pblID ^ "'")); -fun metID2guh (metID:metID) = - (((#guh o get_met) metID) - handle _ => raise error ("metID2guh: no 'Met_' for '"^ - strs2str' metID ^ "'")); -fun kestoreID2guh Pbl_ (kestoreID:kestoreID) = pblID2guh kestoreID - | kestoreID2guh Met_ (kestoreID:kestoreID) = metID2guh kestoreID - | kestoreID2guh ketype kestoreID = - raise error ("kestoreID2guh: '" ^ ketype2str ketype ^ "' not for '" ^ - strs2str' kestoreID ^ "'"); - -fun show_pblguhs () = - (print_depth 999; - (writeln o strs2str o (map linefeed)) (coll_pblguhs (!ptyps)); - print_depth 3); -fun sort_pblguhs () = - (print_depth 999; - (writeln o strs2str o (map linefeed)) - (((sort string_ord) o coll_pblguhs) (!ptyps)); - print_depth 3); - -fun show_metguhs () = - (print_depth 999; - (writeln o strs2str o (map linefeed)) (coll_metguhs (!mets)); - print_depth 3); -fun sort_metguhs () = - (print_depth 999; - (writeln o strs2str o (map linefeed)) - (((sort string_ord) o coll_metguhs) (!mets)); - print_depth 3); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/rewtools.sml --- a/src/Tools/isac/ME/rewtools.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,845 +0,0 @@ -(* tools for rewriting, reverse rewriting, context to thy concerning rewriting - authors: Walther Neuper 2002, 2006 - (c) due to copyright terms - -use"ME/rewtools.sml"; -use"rewtools.sml"; -*) - - - -(***.reverse rewriting.***) - -(*.derivation for insertin one level of nodes into the calctree.*) -type deriv = (term * rule * (term *term list)) list; - -fun trta2str (t,r,(t',a)) = "\n("^(term2str t)^", "^(rule2str' r)^", ("^ - (term2str t')^", "^(terms2str a)^"))"; -fun trtas2str trtas = (strs2str o (map trta2str)) trtas; -val deriv2str = trtas2str; -fun rta2str (r,(t,a)) = "\n("^(rule2str' r)^", ("^ - (term2str t)^", "^(terms2str a)^"))"; -fun rtas2str rtas = (strs2str o (map rta2str)) rtas; -val deri2str = rtas2str; - - -(*.A1==>...==>An==>(Lhs = Rhs) goes to A1==>...==>An==>(Rhs = Lhs).*) -fun sym_thm thm = - let - val (deriv, {thy_ref = thy_ref, tags = tags, maxidx = maxidx, - shyps = shyps, hyps = hyps, tpairs = tpairs, - prop = prop}) = - rep_thm_G thm; - val (lhs,rhs) = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) prop; - val prop' = case strip_imp_prems' prop of - NONE => Trueprop $ (mk_equality (rhs, lhs)) - | SOME cs => - ins_concl cs (Trueprop $ (mk_equality (rhs, lhs))); - in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end; -(* - (sym RS real_mult_div_cancel1) handle e => print_exn e; -Exception THM 1 raised: -RSN: no unifiers -"?s = ?t ==> ?t = ?s" -"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n" - - val thm = real_mult_div_cancel1; - val prop = (#prop o rep_thm) thm; - atomt prop; - val ppp = Logic.strip_imp_concl prop; - atomt ppp; - ((#prop o rep_thm o sym_thm o sym_thm) thm) = (#prop o rep_thm) thm; -val it = true : bool - ((sym_thm o sym_thm) thm) = thm; -val it = true : bool - - val thm = real_le_anti_sym; - ((sym_thm o sym_thm) thm) = thm; -val it = true : bool - - val thm = real_minus_zero; - ((sym_thm o sym_thm) thm) = thm; -val it = true : bool -*) - - - -(*.derive normalform of a rls, or derive until SOME goal, - and record rules applied and rewrites. -val it = fn - : theory - -> rls - -> rule list - -> rew_ord : the order of this rls, which 1 theorem of is used - for rewriting 1 single step (?14.4.03) - -> term option : 040214 ??? nonsense ??? - -> term - -> (term * : to this term ... - rule * : ... this rule is applied yielding ... - (term * : ... this term ... - term list)) : ... under these assumptions. - list : -returns empty list for a normal form -FIXME.WN040214: treats rules as in Rls, _not_ as in Seq - -WN060825 too complicated for the intended use by cancel_, common_nominator_ -and unreflectedly adapted to extion of rules by Rls_: returns Rls_("sym_simpl.. - -- replaced below*) -(* val (thy, erls, rs, ro, goal, tt) = (thy, erls, rs, ro, goal, t); - val (thy, erls, rs, ro, goal, tt) = (thy, Atools_erls, rules, ro, NONE, tt); - *) -fun make_deriv thy erls (rs:rule list) ro(*rew_ord*) goal tt = - let datatype switch = Appl | Noap - fun rew_once lim rts t Noap [] = - (case goal of - NONE => rts - | SOME g => - raise error ("make_deriv: no derivation for "^(term2str t))) - | rew_once lim rts t Appl [] = - (*(case rs of Rls _ =>*) rew_once lim rts t Noap rs - (*| Seq _ => rts) FIXXXXXME 14.3.03*) - | rew_once lim rts t apno rs' = - (case goal of - NONE => rew_or_calc lim rts t apno rs' - | SOME g => - if g = t then rts - else rew_or_calc lim rts t apno rs') - and rew_or_calc lim rts t apno (rrs' as (r::rs')) = - if lim < 0 - then (writeln ("make_deriv exceeds " ^ int2str (!lim_deriv) ^ - "with deriv =\n"); writeln (deriv2str rts); rts) - else - case r of - Thm (thmid, tm) => - (if not (!trace_rewrite) then () else - writeln ("### trying thm '" ^ thmid ^ "'"); - case rewrite_ thy ro erls true tm t of - NONE => rew_once lim rts t apno rs' - | SOME (t',a') => - (if ! trace_rewrite - then writeln ("### rewrites to: "^(term2str t')) else(); - rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs')) - | Calc (c as (op_,_)) => - let val _ = if not (!trace_rewrite) then () else - writeln ("### trying calc. '" ^ op_ ^ "'") - val t = uminus_to_string t - in case get_calculation_ thy c t of - NONE => rew_once lim rts t apno rs' - | SOME (thmid, tm) => - (let val SOME (t',a') = rewrite_ thy ro erls true tm t - val _ = if not (!trace_rewrite) then () else - writeln("### calc. to: " ^ (term2str t')) - val r' = Thm (thmid, tm) - in rew_once (lim-1) (rts@[(t,r',(t',a'))]) t' Appl rrs' - end) - handle _ => raise error "derive_norm, Calc: no rewrite" - end -(* TODO.WN080222: see rewrite__set_ - @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - | Cal1 (cc as (op_,_)) => - (let val _= if !trace_rewrite andalso i < ! depth then - writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else (); - val ct = uminus_to_string ct - in case get_calculation_ thy cc ct of - NONE => (ct, asm) - | SOME (thmid, thm') => - let - val pairopt = - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) - ((#erls o rep_rls) rls) put_asm thm' ct; - val _ = if pairopt <> NONE then () - else raise error("rewrite_set_, rewrite_ \""^ - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") - val _ = if ! trace_rewrite andalso i < ! depth - then writeln((idt"="(i+1))^" cal1. to: "^ - (term2str ((fst o the) pairopt))) - else() - in the pairopt end - end) -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) - | Rls_ rls => - (case rewrite_set_ thy true rls t of - NONE => rew_once lim rts t apno rs' - | SOME (t',a') => - rew_once (lim-1) (rts @ [(t,r,(t',a'))]) t' Appl rrs'); -(*WN060829 | Rls_ rls => - (case rewrite_set_ thy true rls t of - NONE => rew_once lim rts t apno rs' - | SOME (t',a') => - if ro [] (t, t') then rew_once lim rts t apno rs' - else rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs'); -...lead to deriv = [] with make_polynomial. -THERE IS SOMETHING DIFFERENT beetween rewriting with the code above -and between rewriting with rewrite_set: with rules from make_polynomial and -t = "(a^^^2 + -1*b^^^2) / (a^^^2 + -2*a*b + b^^^2)" the actual code -leads to cycling Rls_ order_mult_rls_..Rls_ discard_parentheses_..Rls_ order.. -*) - in rew_once (!lim_deriv) [] tt Noap rs end; - - -(*.toggles the marker for 'fun sym_thm'.*) -fun sym_thmID (thmID : thmID) = - case explode thmID of - "s"::"y"::"m"::"_"::id => implode id : thmID - | id => "sym_"^thmID; -(* -> val thmID = "sym_real_mult_2"; -> sym_thmID thmID; -val it = "real_mult_2" : string -> val thmID = "real_num_collect"; -> sym_thmID thmID; -val it = "sym_real_num_collect" : string*) -fun sym_drop (thmID : thmID) = - case explode thmID of - "s"::"y"::"m"::"_"::id => implode id : thmID - | id => thmID; -fun is_sym (thmID : thmID) = - case explode thmID of - "s"::"y"::"m"::"_"::id => true - | id => false; - - -(*FIXXXXME.040219: detail has to handle Rls id="sym_..." - by applying make_deriv, rev_deriv'; see concat_deriv*) -fun sym_rls Erls = Erls - | sym_rls (Rls {id, scr, calc, erls, srls, rules, rew_ord, preconds}) = - Rls {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls, - rules=rules, rew_ord=rew_ord, preconds=preconds} - | sym_rls (Seq {id, scr, calc, erls, srls, rules, rew_ord, preconds}) = - Seq {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls, - rules=rules, rew_ord=rew_ord, preconds=preconds} - | sym_rls (Rrls {id, scr, calc, erls, prepat, rew_ord}) = - Rrls {id="sym_"^id, scr=scr, calc=calc, erls=erls, prepat=prepat, - rew_ord=rew_ord}; - -fun sym_Thm (Thm (thmID, thm)) = Thm (sym_thmID thmID, sym_thm thm) - | sym_Thm (Rls_ rls) = Rls_ (*WN060825?!?*) (sym_rls rls) - | sym_Thm r = raise error ("sym_Thm: not for "^(rule2str r)); -(* - val th = Thm ("real_one_collect",num_str real_one_collect); - sym_Thm th; -val th = - Thm ("real_one_collect","?m is_const ==> ?n + ?m * ?n = (1 + ?m) * ?n") - : rule -ML> val it = - Thm ("sym_real_one_collect","?m is_const ==> (1 + ?m) * ?n = ?n + ?m * ?n")*) - - -(*version for reverse rewrite used before 040214*) -fun rev_deriv (t, r, (t', a)) = (sym_Thm r, (t, a)); -(* val (thy, erls, rs, ro, goal, t) = (thy, eval_rls, rules, ro, NONE, t'); - *) -fun reverse_deriv thy erls (rs:rule list) ro(*rew_ord*) goal t = - (rev o (map rev_deriv)) (make_deriv thy erls (rs:rule list) ro goal t); -(* - val rev_rew = reverse_deriv thy e_rls ; - writeln(rtas2str rev_rew); -*) - -fun eq_Thm (Thm (id1,_), Thm (id2,_)) = id1 = id2 - | eq_Thm (Thm (id1,_), _) = false - | eq_Thm (Rls_ r1, Rls_ r2) = id_rls r1 = id_rls r2 - | eq_Thm (Rls_ r1, _) = false - | eq_Thm (r1, r2) = raise error ("eq_Thm: called with '"^ - (rule2str r1)^"' '"^(rule2str r2)^"'"); -fun distinct_Thm r = gen_distinct eq_Thm r; - -fun eq_Thms thmIDs thm = (member op = thmIDs (id_of_thm thm)) - handle _ => false; - - -(***. context to thy concerning rewriting .***) - -(*.create the unique handles and filenames for the theory-data.*) -fun part2guh ([str]:theID) = - (case str of - "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh - | "IsacScripts" => "thy_scri_" ^ str ^ "-part" - | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part" - | str => raise error ("thy2guh: called with '"^str^"'")) - | part2guh theID = raise error ("part2guh called with theID = " - ^ theID2str theID); -fun part2filename str = part2guh str ^ ".xml" : filename; - - -fun thy2guh ([part, thyID]:theID) = - (case part of - "Isabelle" => "thy_isab_" ^ thyID : guh - | "IsacScripts" => "thy_scri_" ^ thyID - | "IsacKnowledge" => "thy_isac_" ^ thyID - | str => raise error ("thy2guh: called with '"^str^"'")) - | thy2guh theID = raise error ("thy2guh called with '"^strs2str' theID^"'"); -fun thy2filename thy' = thy2guh thy' ^ ".xml" : filename; -fun thypart2guh ([part, thyID, thypart]:theID) = - case part of - "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh - | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart - | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart - | str => raise error ("thypart2guh: called with '"^str^"'"); -fun thypart2filename thy' = thypart2guh thy' ^ ".xml" : filename; - -(*.convert the data got via contextToThy to a globally unique handle - there is another way to get the guh out of the 'theID' in the hierarchy.*) -fun thm2guh (isa, thyID:thyID) (thmID:thmID) = - case isa of - "Isabelle" => - "thy_isab_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh - | "IsacKnowledge" => - "thy_isac_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID - | "IsacScripts" => - "thy_scri_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID - | str => raise error ("thm2guh called with isa = '"^isa^ - "' for thm = "^thmID^"'"); -fun thm2filename (isa_thyID: string * thyID) thmID = - (thm2guh isa_thyID thmID) ^ ".xml" : filename; - -fun rls2guh (isa, thyID:thyID) (rls':rls') = - case isa of - "Isabelle" => - "thy_isab_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' : guh - | "IsacKnowledge" => - "thy_isac_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' - | "IsacScripts" => - "thy_scri_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' - | str => raise error ("rls2guh called with isa = '"^isa^ - "' for rls = '"^rls'^"'"); - fun rls2filename (isa, thyID) rls' = - rls2guh (isa, thyID) rls' ^ ".xml" : filename; - -fun cal2guh (isa, thyID:thyID) calID = - case isa of - "Isabelle" => - "thy_isab_" ^ theory'2thyID thyID ^ "-cal-" ^ calID : guh - | "IsacKnowledge" => - "thy_isac_" ^ theory'2thyID thyID ^ "-cal-" ^ calID - | "IsacScripts" => - "thy_scri_" ^ theory'2thyID thyID ^ "-cal-" ^ calID - | str => raise error ("cal2guh called with isa = '"^isa^ - "' for cal = '"^calID^"'"); -fun cal2filename (isa, thyID:thyID) calID = - cal2guh (isa, thyID:thyID) calID ^ ".xml" : filename; - -fun ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') = - case isa of - "Isabelle" => - "thy_isab_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh - | "IsacKnowledge" => - "thy_isac_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' - | "IsacScripts" => - "thy_scri_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' - | str => raise error ("ord2guh called with isa = '"^isa^ - "' for ord = '"^rew_ord'^"'"); -fun ord2filename (isa, thyID:thyID) (rew_ord':rew_ord') = - ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') ^ ".xml" : filename; - - -(**.set up isab_thm_thy in Isac.ML.**) - -fun rearrange (thyID, (thmID, thm)) = (thmID, (thyID, thm)); -fun rearrange_inv (thmID, (thyID, thm)) = (thyID, (thmID, thm)); - -(*.lookup the missing theorems in some thy (of Isabelle).*) -fun make_isa missthms thy = - map (pair (theory2thyID thy)) - ((inter eq_thmI) missthms (PureThy.all_thms_of thy)) - : (thyID * (thmID * Thm.thm)) list; - -(*.separate handling of sym_thms.*) -fun make_isab rlsthmsNOTisac isab_thys = - let fun les ((s1,_), (s2,_)) = (s1 : string) < s2 - val notsym = filter_out (is_sym o #1) rlsthmsNOTisac - val notsym_isab = (flat o (map (make_isa notsym))) isab_thys - - val sym = filter (is_sym o #1) rlsthmsNOTisac - - val symsym = map ((apfst sym_drop) o (apsnd sym_thm)) sym - val symsym_isab = (flat o (map (make_isa symsym))) isab_thys - - val sym_isab = map (((apsnd o apfst) sym_drop) o - ((apsnd o apsnd) sym_thm)) symsym_isab - - val isab = notsym_isab @ symsym_isab @ sym_isab - in ((map rearrange) o (gen_sort les)) isab - : (thmID * (thyID * Thm.thm)) list - end; - -(*.which theory below thy' contains a theorem; this can be in isabelle ! -get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*) -(* val (str, (_, thy)) = ("real_diff_minus", ("Root.thy", Root.thy)); - val (str, (_, thy)) = ("real_diff_minus", ("Poly.thy", Poly.thy)); - *) -fun thy_contains_thm (str:xstring) (_, thy) = - member op = (map (strip_thy o fst) (PureThy.all_thms_of thy)) str; -(* val (thy', str) = ("Isac.thy", "real_mult_minus1"); - val (thy', str) = ("PolyMinus.thy", "klammer_minus_plus"); - *) -fun thy_containing_thm (thy':theory') (str:xstring) = - let val thy' = thyID2theory' thy' - val str = sym_drop str - val startsearch = dropuntil ((curry op= thy') o - (#1:theory' * theory -> theory')) - (rev (!theory')) - in case find_first (thy_contains_thm str) startsearch of - SOME (thy',_) => ("IsacKnowledge", thy') - | NONE => (case assoc (!isab_thm_thy (*see Isac.ML*), str) of - SOME (thyID,_) => ("Isabelle", thyID) - | NONE => - raise error ("thy_containing_thm: theorem '"^str^ - "' not in !theory' above thy '"^thy'^"'")) - end; - - -(*.which theory below thy' contains a ruleset; -get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*) -(* val (thy', rls') = ("PolyEq.thy", "separate_bdv"); - *) -local infix mem; (*from Isabelle2002*) -fun x mem [] = false - | x mem (y :: ys) = x = y orelse x mem ys; -in -fun thy_containing_rls (thy':theory') (rls':rls') = - let val rls' = strip_thy rls' - val thy' = thyID2theory' thy' - (*take thys between "Isac" and thy' not to search #1#*) - val dropthys = takewhile [] (not o (curry op= thy') o - (#1:theory' * theory -> theory')) - (rev (!theory')) - val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory')) - dropthys - (*drop those rulesets which are generated in a theory found in #1#*) - val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o - ((#1 o #2) : rls' * (theory' * rls) - -> theory')) - (rev (!ruleset')) - in case assoc (startsearch, rls') of - SOME (thy', _) => ("IsacKnowledge", thyID2theory' thy') - | _ => raise error ("thy_containing_rls : rls '"^rls'^ - "' not in !rulset' above thy '"^thy'^"'") - end; -(* val (thy', termop) = (thyID, termop); - *) -fun thy_containing_cal (thy':theory') termop = - let val thy' = thyID2theory' thy' - val dropthys = takewhile [] (not o (curry op= thy') o - (#1:theory' * theory -> theory')) - (rev (!theory')) - val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory')) - dropthys - val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o - (#1 : calc -> string)) (rev (!calclist')) - in case assoc (startsearch, strip_thy termop) of - SOME (th_termop, _) => ("IsacKnowledge", strip_thy th_termop) - | _ => raise error ("thy_containing_rls : rls '"^termop^ - "' not in !calclist' above thy '"^thy'^"'") - end -end; - -(* print_depth 99; map #1 startsearch; print_depth 3; - *) - -(*.packing return-values to matchTheory, contextToThy for xml-generation.*) -datatype contthy = (*also an item from KEStore on Browser ......#*) - EContThy (*not from KEStore ...........................*) - | ContThm of (*a theorem in contex =============*) - {thyID : thyID, (*for *2guh in sub-elems here .*) - thm : guh, (*theorem in the context .*) - applto : term, (*applied to formula ... .*) - applat : term, (*... with lhs inserted .*) - reword : rew_ord', (*order used for rewrite .*) - asms : (term (*asumption instantiated .*) - * term) list, (*asumption evaluated .*) - lhs : term (*lhs of the theorem ... #*) - * term, (*... instantiated .*) - rhs : term (*rhs of the theorem ... #*) - * term, (*... instantiated .*) - result : term, (*resulting from the rewrite .*) - resasms : term list, (*... with asms stored .*) - asmrls : rls' (*ruleset for evaluating asms .*) - } - | ContThmInst of (*a theorem with bdvs in contex ======== *) - {thyID : thyID, (*for *2guh in sub-elems here .*) - thm : guh, (*theorem in the context .*) - bdvs : subst, (*bound variables to modify....*) - thminst : term, (*... theorem instantiated .*) - applto : term, (*applied to formula ... .*) - applat : term, (*... with lhs inserted .*) - reword : rew_ord', (*order used for rewrite .*) - asms : (term (*asumption instantiated .*) - * term) list, (*asumption evaluated .*) - lhs : term (*lhs of the theorem ... #*) - * term, (*... instantiated .*) - rhs : term (*rhs of the theorem ... #*) - * term, (*... instantiated .*) - result : term, (*resulting from the rewrite .*) - resasms : term list, (*... with asms stored .*) - asmrls : rls' (*ruleset for evaluating asms .*) - } - | ContRls of (*a rule set in contex ===================== *) - {thyID : thyID, (*for *2guh in sub-elems here .*) - rls : guh, (*rule set in the context .*) - applto : term, (*rewrite this formula .*) - result : term, (*resulting from the rewrite .*) - asms : term list (*... with asms stored .*) - } - | ContRlsInst of (*a rule set with bdvs in contex ======= *) - {thyID : thyID, (*for *2guh in sub-elems here .*) - rls : guh, (*rule set in the context .*) - bdvs : subst, (*for bound variables in thms .*) - applto : term, (*rewrite this formula .*) - result : term, (*resulting from the rewrite .*) - asms : term list (*... with asms stored .*) - } - | ContNOrew of (*no rewrite for thm or rls ============== *) - {thyID : thyID, (*for *2guh in sub-elems here .*) - thm_rls : guh, (*thm or rls in the context .*) - applto : term (*rewrite this formula .*) - } - | ContNOrewInst of (*no rewrite for some instantiation == *) - {thyID : thyID, (*for *2guh in sub-elems here .*) - thm_rls : guh, (*thm or rls in the context .*) - bdvs : subst, (*for bound variables in thms .*) - thminst : term, (*... theorem instantiated .*) - applto : term (*rewrite this formula .*) - }; - -(*.check a rewrite-tac for bdv (RL always used *_Inst !) TODO.WN060718 - pass other tacs unchanged.*) -fun get_tac_checked pt ((p,p_) : pos') = get_obj g_tac pt p; - -(*..*) - - - -(*.get the formula f at ptp rewritten by the Rewrite_* already applied to f.*) -(* val (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) = tac'; - *) -fun context_thy (pt, pos as (p,p_)) (tac as Rewrite (thmID,_)) = - (case applicable_in pos pt tac of - Appl (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) => - let val thy = assoc_thy thy' - val thm = (norm o #prop o rep_thm o (PureThy.get_thm thy)) thmID - (*WN060616 the following must be done on subterm found _IN_ rew_sub - val (lhs,rhs) = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) thm - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f) - val thm' = ren_inst (insts, thm, lhs, f) - val (lhs',rhs') = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) thm' - val asms = map strip_trueprop (Logic.strip_imp_prems thm) - val asms' = map strip_trueprop (Logic.strip_imp_prems thm') - *) - in ContThm {thyID = theory'2thyID thy', - thm = thm2guh (thy_containing_thm thy' thmID) thmID, - applto = f, - applat = e_term, - reword = ord', - asms = [](*asms ~~ asms'*), - lhs = (e_term, e_term)(*(lhs, lhs')*), - rhs = (e_term, e_term)(*(rhs, rhs')*), - result = res, - resasms = asm, - asmrls = id_rls erls} - end - | Notappl _ => - let val pp = par_pblobj pt p - val thy' = get_obj g_domID pt pp - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - in ContNOrew {thyID = theory'2thyID thy', - thm_rls = thm2guh (thy_containing_thm thy' thmID) thmID, - applto = f} - end) - -(* val ((pt,p), tac as Rewrite_Inst (subs, (thmID,_))) = ((pt,pos), tac); - *) - | context_thy (pt, pos as (p,p_)) - (tac as Rewrite_Inst (subs, (thmID,_))) = - (case applicable_in pos pt tac of -(* val Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_), - f, (res,asm))) = applicable_in p pt tac; - *) - Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_), - f, (res,(*path to subterm,*)asm))) => - let val thm = (norm o #prop o rep_thm o - (PureThy.get_thm (assoc_thy thy'))) thmID - val thminst = inst_bdv subst thm - (*WN060616 the following must be done on subterm found _IN_ rew_sub - val (lhs,rhs) = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) thminst - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f) - val thm' = ren_inst (insts, thminst, lhs, f) - val (lhs',rhs') = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) thm' - val asms = map strip_trueprop (Logic.strip_imp_prems thminst) - val asms' = map strip_trueprop (Logic.strip_imp_prems thm') - *) - in ContThmInst {thyID = theory'2thyID thy', - thm = thm2guh (thy_containing_thm - thy' thmID) thmID, - bdvs = subst, - thminst = thminst, - applto = f, - applat = e_term, - reword = ord', - asms = [](*asms ~~ asms'*), - lhs = (e_term, e_term)(*(lhs, lhs')*), - rhs = (e_term, e_term)(*(rhs, rhs')*), - result = res, - resasms = asm, - asmrls = id_rls erls} - end - | Notappl _ => - let val pp = par_pblobj pt p - val thy' = get_obj g_domID pt pp - val subst = subs2subst (assoc_thy thy') subs - val thm = (norm o #prop o rep_thm o - (PureThy.get_thm (assoc_thy thy'))) thmID - val thminst = inst_bdv subst thm - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - in ContNOrewInst {thyID = theory'2thyID thy', - thm_rls = thm2guh (thy_containing_thm - thy' thmID) thmID, - bdvs = subst, - thminst = thminst, - applto = f} - end) - | context_thy (pt,p) (tac as Rewrite_Set rls') = - (case applicable_in p pt tac of - Appl (Rewrite_Set' (thy', _, rls, f, (res,asm))) => - ContRls {thyID = theory'2thyID thy', - rls = rls2guh (thy_containing_rls thy' rls') rls', - applto = f, - result = res, - asms = asm}) - | context_thy (pt,p) (tac as Rewrite_Set_Inst (subs, rls')) = - (case applicable_in p pt tac of - Appl (Rewrite_Set_Inst' (thy', _, subst, rls, f, (res,asm))) => - ContRlsInst {thyID = theory'2thyID thy', - rls = rls2guh (thy_containing_rls thy' rls') rls', - bdvs = subst, - applto = f, - result = res, - asms = asm}); - -(*.get all theorems in a rule set (recursivley containing rule sets).*) -fun thm_of_rule Erule = [] - | thm_of_rule (thm as Thm _) = [thm] - | thm_of_rule (Calc _) = [] - | thm_of_rule (Cal1 _) = [] - | thm_of_rule (Rls_ rls) = thms_of_rls rls -and thms_of_rls Erls = [] - | thms_of_rls (Rls {rules,...}) = (flat o (map thm_of_rule)) rules - | thms_of_rls (Seq {rules,...}) = (flat o (map thm_of_rule)) rules - | thms_of_rls (Rrls _) = []; -(* val Hrls {thy_rls = (_, rls),...} = - get_the ["IsacKnowledge", "Test", "Rulesets", "expand_binomtest"]; -> thms_of_rls rls; - *) - -(*. check if a rule is contained in a rule-set (recursivley down in Rls_); - this rule can even be a rule-set itself.*) -fun contains_rule r rls = - let fun find (r, Rls_ rls) = finds (get_rules rls) - | find r12 = eq_rule r12 - and finds [] = false - | finds (r1 :: rs) = if eq_rule (r, r1) then true else finds rs; - in - (*writeln ("### contains_rule: r = "^rule2str r^", rls = "^rls2str rls);*) - finds (get_rules rls) - end; - -(*. try if a rewrite-rule is applicable to a given formula; - in case of rule-sets (recursivley) collect all _atomic_ rewrites .*) -fun try_rew thy ((_, ro):rew_ord) erls (subst:subst) f (thm' as Thm(id, thm)) = - if contains_bdv thm - then case rewrite_inst_ thy ro erls false subst thm f of - SOME (f',_) =>[rule2tac subst thm'] - | NONE => [] - else (case rewrite_ thy ro erls false thm f of - SOME (f',_) => [rule2tac [] thm'] - | NONE => []) - | try_rew thy _ _ _ f (cal as Calc c) = - (case get_calculation_ thy c f of - SOME (str, _) => [rule2tac [] cal] - | NONE => []) - | try_rew thy _ _ _ f (cal as Cal1 c) = - (case get_calculation_ thy c f of - SOME (str, _) => [rule2tac [] cal] - | NONE => []) - | try_rew thy _ _ subst f (Rls_ rls) = filter_appl_rews thy subst f rls -and filter_appl_rews thy subst f (Rls {rew_ord = ro, erls, rules,...}) = - distinct (flat (map (try_rew thy ro erls subst f) rules)) - | filter_appl_rews thy subst f (Seq {rew_ord = ro, erls, rules,...}) = - distinct (flat (map (try_rew thy ro erls subst f) rules)) - | filter_appl_rews thy subst f (Rrls _) = []; - -(*. decide if a tactic is applicable to a given formula; - in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*) -(* val - *) -fun atomic_appl_tacs thy _ _ f (Calculate scrID) = - try_rew thy e_rew_ordX e_rls [] f (Calc (snd(assoc1 (!calclist', scrID)))) - | atomic_appl_tacs thy ro erls f (Rewrite (thm' as (thmID, _))) = - try_rew thy (ro, assoc_rew_ord ro) erls [] f - (Thm (thmID, assoc_thm' thy thm')) - | atomic_appl_tacs thy ro erls f (Rewrite_Inst (subs, thm' as (thmID, _))) = - try_rew thy (ro, assoc_rew_ord ro) erls (subs2subst thy subs) f - (Thm (thmID, assoc_thm' thy thm')) - - | atomic_appl_tacs thy _ _ f (Rewrite_Set rls') = - filter_appl_rews thy [] f (assoc_rls rls') - | atomic_appl_tacs thy _ _ f (Rewrite_Set_Inst (subs, rls')) = - filter_appl_rews thy (subs2subst thy subs) f (assoc_rls rls') - | atomic_appl_tacs _ _ _ _ tac = - (writeln ("### atomic_appl_tacs: not impl. for tac = '"^ tac2str tac ^"'"); - []); - - - - - -(*.not only for thydata, but also for thy's etc.*) -fun theID2guh (theID:theID) = - case length theID of - 0 => raise error ("theID2guh: called with theID = "^strs2str' theID) - | 1 => part2guh theID - | 2 => thy2guh theID - | 3 => thypart2guh theID - | 4 => let val [isa, thyID, typ, elemID] = theID - in case typ of - "Theorems" => thm2guh (isa, thyID) elemID - | "Rulesets" => rls2guh (isa, thyID) elemID - | "Calculations" => cal2guh (isa, thyID) elemID - | "Orders" => ord2guh (isa, thyID) elemID - | "Theorems" => thy2guh [isa, thyID] - | str => raise error ("theID2guh: called with theID = "^ - strs2str' theID) - end - | n => raise error ("theID2guh called with theID = "^strs2str' theID); -(*.filenames not only for thydata, but also for thy's etc.*) -fun theID2filename (theID:theID) = theID2guh theID ^ ".xml" : filename; - -fun guh2theID (guh:guh) = - let val guh' = explode guh - val part = implode (take_fromto 1 4 guh') - val isa = implode (take_fromto 5 9 guh') - in if not (member op = ["exp_", "thy_", "pbl_", "met_"] part) - then raise error ("guh '"^guh^"' does not begin with \ - \exp_ | thy_ | pbl_ | met_") - else let val chap = case isa of - "isab_" => "Isabelle" - | "scri_" => "IsacScripts" - | "isac_" => "IsacKnowledge" - | _ => - raise error ("guh2theID: '"^guh^ - "' does not have isab_ | scri_ | \ - \isac_ at position 5..9") - val rest = takerest (9, guh') - val thyID = takewhile [] (not o (curry op= "-")) rest - val rest' = dropuntil (curry op= "-") rest - in case implode rest' of - "-part" => [chap] : theID - | "" => [chap, implode thyID] - | "-Theorems" => [chap, implode thyID, "Theorems"] - | "-Rulesets" => [chap, implode thyID, "Rulesets"] - | "-Operations" => [chap, implode thyID, "Operations"] - | "-Orders" => [chap, implode thyID, "Orders"] - | _ => - let val sect = implode (take_fromto 1 5 rest') - val sect' = - case sect of - "-thm-" => "Theorems" - | "-rls-" => "Rulesets" - | "-cal-" => "Operations" - | "-ord-" => "Orders" - | str => - raise error ("guh2theID: '"^guh^"' has '"^sect^ - "' instead -thm- | -rls- | \ - \-cal- | -ord-") - in [chap, implode thyID, sect', implode - (takerest (5, rest'))] - end - end - end; -(*> guh2theID "thy_isac_Biegelinie-Theorems"; -val it = ["IsacKnowledge", "Biegelinie", "Theorems"] : theID -> guh2theID "thy_scri_ListG-thm-zip_Nil"; -val it = ["IsacScripts", "ListG", "Theorems", "zip_Nil"] : theID*) - -fun guh2filename (guh : guh) = guh ^ ".xml" : filename; - - -(*..*) -fun guh2rewtac (guh:guh) ([] : subs) = - let val [isa, thy, sect, xstr] = guh2theID guh - in case sect of - "Theorems" => Rewrite (xstr, "") - | "Rulesets" => Rewrite_Set xstr - | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'") - end - | guh2rewtac (guh:guh) subs = - let val [isa, thy, sect, xstr] = guh2theID guh - in case sect of - "Theorems" => Rewrite_Inst (subs, (xstr, "")) - | "Rulesets" => Rewrite_Set_Inst (subs, xstr) - | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'") - end; -(*> guh2rewtac "thy_isac_Test-thm-constant_mult_square" []; -val it = Rewrite ("constant_mult_square", "") : tac -> guh2rewtac "thy_isac_Test-thm-risolate_bdv_add" ["(bdv, x)"]; -val it = Rewrite_Inst (["(bdv, x)"], ("risolate_bdv_add", "")) : tac -> guh2rewtac "thy_isac_Test-rls-Test_simplify" []; -val it = Rewrite_Set "Test_simplify" : tac -> guh2rewtac "thy_isac_Test-rls-isolate_bdv" ["(bdv, x)"]; -val it = Rewrite_Set_Inst (["(bdv, x)"], "isolate_bdv") : tac*) - - -(*.the front-end may request a context for any element of the hierarchy.*) -(* val guh = "thy_isac_Test-rls-Test_simplify"; - *) -fun no_thycontext (guh : guh) = (guh2theID guh; false) - handle _ => true; - -(*> has_thycontext "thy_isac_Test"; -if has_thycontext "thy_isac_Test" then "OK" else "NOTOK"; - *) - - - -(*.get the substitution of bound variables for matchTheory: - # lookup the thm|rls' in the script - # take the [(bdv, v_),..] from the respective Rewrite_(Set_)Inst - # instantiate this subs with the istates env to [(bdv, x),..] - # otherwise [].*) -(*WN060617 hack assuming that all scripts use only one bound variable -and use 'v_' as the formal argument for this bound variable*) -(* val (ScrState (env,_,_,_,_,_), _, guh) = (is, "dummy", guh); - *) -fun subs_from (ScrState (env,_,_,_,_,_)) _(*:Script sc*) (guh:guh) = - let val theID as [isa, thyID, sect, xstr] = guh2theID guh - in case sect of - "Theorems" => - let val thm = PureThy.get_thm (assoc_thy (thyID2theory' thyID)) xstr - in if contains_bdv thm - then let val formal_arg = str2term "v_" - val value = subst_atomic env formal_arg - in ["(bdv," ^ term2str value ^ ")"]:subs end - else [] - end - | "Rulesets" => - let val rules = (get_rules o assoc_rls) xstr - in if contain_bdv rules - then let val formal_arg = str2term"v_" - val value = subst_atomic env formal_arg - in ["(bdv,"^term2str value^")"]:subs end - else [] - end - end; - -(* use"ME/rewtools.sml"; - *) - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/script.sml --- a/src/Tools/isac/ME/script.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2031 +0,0 @@ -(* interpreter for scripts - (c) Walther Neuper 2000 - -use"ME/script.sml"; -use"script.sml"; -*) -signature INTERPRETER = -sig - (*type ets (list of executed tactics) see sequent.sml*) - - datatype locate - = NotLocatable - | Steps of (tac_ * mout * ptree * pos' * cid * safe (* ets*)) list -(* | ToDo of ets 28.4.02*) - - (*diss: next-tactic-function*) - val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> tac_ - (*diss: locate-function*) - val locate_gen : theory' - -> tac_ - -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate - - val sel_rules : ptree -> pos' -> tac list - val init_form : scr -> ets -> loc_ * term option (*FIXME not up to date*) - val formal_args : term -> term list - - (*shift to library ...*) - val inst_abs : theory' -> term -> term - val itms2args : metID -> itm list -> term list - val user_interrupt : loc_ * (tac_ * env * env * term * term * safe) - (*val empty : term*) -end - - - - -(* -structure Interpreter : INTERPRETER = -struct -*) - -(*.traces the leaves (ie. non-tactical nodes) of the script - found by next_tac. - a leaf is either a tactic or an 'exp' in 'let v = expr' - where 'exp' does not contain a tactic.*) -val trace_script = ref false; - -type step = (*data for creating a new node in the ptree; - designed for use: - fun ass* scrstate steps = - ... case ass* scrstate steps of - Assoc (scrstate, steps) => ... ass* scrstate steps*) - tac_ (*transformed from associated tac*) - * mout (*result with indentation etc.*) - * ptree (*containing node created by tac_ + resp. scrstate*) - * pos' (*position in ptree; ptree * pos' is the proofstate*) - * pos' list; (*of ptree-nodes probably cut (by fst tac_)*) -val e_step = (Empty_Tac_, EmptyMout, EmptyPtree, e_pos',[]:pos' list):step; - -fun rule2thm' (Thm (id, thm)) = (id, string_of_thmI thm):thm' - | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r)); -fun rule2rls' (Rls_ rls) = id_rls rls - | rule2rls' r = raise error ("rule2rls': not defined for "^(rule2str r)); - -(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve; - complicated with current t in rrlsstate.*) -fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] = - let val thy = assoc_thy thy' - val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am)) - val is = RrlsState (f',f'',rss,rts) - val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res) - val (p', cid, mout, pt') = generate1 thy m is p pt - in (is, (m, mout, pt', p', cid)::steps) end - | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) - ((r, (f', am))::rts') = - let val thy = assoc_thy thy' - val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am)) - val is = RrlsState (f',f'',rss,rts) - val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res) - val (p', cid, mout, pt') = generate1 thy m is p pt - in rts2steps ((m, mout, pt', p', cid)::steps) - ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end; - - -(*. functions for the environment stack .*) -fun accessenv id es = the (assoc((top es):env, id)) - handle _ => error ("accessenv: "^(free2str id)^" not in env"); -fun updateenv id vl (es:env stack) = - (push (overwrite(top es, (id, vl))) (pop es)):env stack; -fun pushenv id vl (es:env stack) = - (push (overwrite(top es, (id, vl))) es):env stack; -val popenv = pop:env stack -> env stack; - - - -fun de_esc_underscore str = - let fun scan [] = [] - | scan (s::ss) = if s = "'" then (scan ss) - else (s::(scan ss)) - in (implode o scan o explode) str end; -(* -> val str = "Rewrite_Set_Inst"; -> val esc = esc_underscore str; -val it = "Rewrite'_Set'_Inst" : string -> val des = de_esc_underscore esc; - val des = de_esc_underscore esc;*) - -(*go at a location in a script and fetch the contents*) -fun go [] t = t - | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0 - | go (L::p) (t1 $ t2) = go p t1 - | go (R::p) (t1 $ t2) = go p t2 - | go l _ = raise error ("go: no "^(loc_2str l)); -(* -> val t = (term_of o the o (parse thy)) "a+b"; -val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term -> val plus_a = go [L] t; -> val b = go [R] t; -> val plus = go [L,L] t; -> val a = go [L,R] t; - -> val t = (term_of o the o (parse thy)) "a+b+c"; -val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term -> val pl_pl_a_b = go [L] t; -> val c = go [R] t; -> val a = go [L,R,L,R] t; -> val b = go [L,R,R] t; -*) - - -(* get a subterm t with test t, and record location *) -fun get l test (t as Const (s,T)) = - if test t then SOME (l,t) else NONE - | get l test (t as Free (s,T)) = - if test t then SOME (l,t) else NONE - | get l test (t as Bound n) = - if test t then SOME (l,t) else NONE - | get l test (t as Var (s,T)) = - if test t then SOME (l,t) else NONE - | get l test (t as Abs (s,T,body)) = - if test t then SOME (l:loc_,t) else get ((l@[D]):loc_) test body - | get l test (t as t1 $ t2) = - if test t then SOME (l,t) - else case get (l@[L]) test t1 of - NONE => get (l@[R]) test t2 - | SOME (l',t') => SOME (l',t'); -(*18.6.00 -> val sss = ((term_of o the o (parse thy)) - "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\ - \ (let e_ = Try (Rewrite square_equation_left True eq_) \ - \ in [e_])"); - ______ compares head_of !! -> get [] (eq_str "Let") sss; [R] -> get [] (eq_str "Script.Try") sss; [R,L,R] -> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R] -> get [] (eq_str "True") sss; [R,L,R,R,L,R] -> get [] (eq_str "e_") sss; [R,R] -*) - -fun test_negotiable t = - member op = (!negotiable) - ((strip_thy o (term_str (theory "Script")) o head_of) t); - -(*.get argument of first stactic in a script for init_form.*) -fun get_stac thy (h $ body) = -(* - *) - let - fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a = - (case get_t y e1 a of NONE => get_t y e2 a | la => la) - | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ = - (case get_t y e1 a of NONE => get_t y e2 a | la => la) - | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a - | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a - | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a - | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a - | get_t y (Const ("Script.Or",_) $e1 $ e2) a = - (case get_t y e1 a of NONE => get_t y e2 a | la => la) - | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ = - (case get_t y e1 a of NONE => get_t y e2 a | la => la) - | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a - | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a - | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a = - (case get_t y e1 a of NONE => get_t y e2 a | la => la) - (*| get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a = - (writeln("get_t: Let e1= "^(term2str e1)^", e2= "^(term2str e2)); - case get_t y e1 a of NONE => get_t y e2 a | la => la) - | get_t y (Abs (_,_,e)) a = get_t y e a*) - | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a = - get_t y e1 a (*don't go deeper without evaluation !*) - | get_t y (Const ("If",_) $ c $ e1 $ e2) a = NONE - (*(case get_t y e1 a of NONE => get_t y e2 a | la => la)*) - - | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = SOME a - | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = SOME a - | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = SOME a - | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = SOME a - | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = SOME a - | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = SOME a - | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =SOME a - | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =SOME a - | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = SOME a - | get_t y (Const ("Script.Calculate",_) $ _ ) a = SOME a - - | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = SOME a - | get_t y (Const ("Script.Substitute",_) $ _ ) a = SOME a - - | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = NONE - - | get_t y x _ = - ((*writeln ("### get_t yac: list-expr "^(term2str x));*) - NONE) -in get_t thy body e_term end; - -(*FIXME: get 1st stac by next_stac [] instead of ... ?? 29.7.02*) -(* val Script sc = scr; - *) -fun init_form thy (Script sc) env = - (case get_stac thy sc of - NONE => NONE (*raise error ("init_form: no 1st stac in "^ - (Syntax.string_of_term (thy2ctxt thy) sc))*) - | SOME stac => SOME (subst_atomic env stac)) - | init_form _ _ _ = raise error "init_form: no match"; - -(* use"ME/script.sml"; - use"script.sml"; - *) - - - -(*the 'iteration-argument' of a stac (args not eval)*) -fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v - | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v - | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v - | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v - | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v - | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts - | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term - | itr_arg _ (Const ("Script.Tac",_) $ _) = e_term - | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term - | itr_arg thy t = raise error - ("itr_arg not impl. for "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)); -(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_"; -> itr_arg "Script.thy" t; -val it = Free ("e_","RealDef.real") : term -> val t = (term_of o the o (parse thy))"xxx"; -> itr_arg "Script.thy" t; -*** itr_arg not impl. for xxx -uncaught exception ERROR - raised at: library.ML:1114.35-1114.40*) - - -(*.get the arguments of the script out of the scripts parsetree.*) -fun formal_args scr = (fst o split_last o snd o strip_comb) scr; -(* -> formal_args scr; - [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"), - Free ("eqs_","bool List.list")] : term list -*) - -(*.get the identifier of the script out of the scripts parsetree.*) -fun id_of_scr sc = (id_of o fst o strip_comb) sc; - - -(*WN020526: not clear, when a is available in ass_up for eva-_true*) -(*WN060906: in "fun handle_leaf" eg. uses "SOME M__"(from some PREVIOUS - curried Rewrite) for CURRENT value (which may be different from PREVIOUS); - thus "NONE" must be set at the end of currying (ill designed anyway)*) -fun upd_env_opt env (SOME a, v) = upd_env env (a,v) - | upd_env_opt env (NONE, v) = - (writeln("*** upd_env_opt: (NONE,"^(term2str v)^")");env); - - -type dsc = typ; (*<-> nam..unknow in Descript.thy*) -fun typ_str (Type (s,_)) = s - | typ_str (TFree(s,_)) = s - | typ_str (TVar ((s,i),_)) = s^(string_of_int i); - -(*get the _result_-type of a description*) -fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T; -(*> val t = (term_of o the o (parse thy)) "equality"; -> val T = type_of t; -val T = "bool => Tools.una" : typ -> val dsc = dsc_valT t; -val dsc = "una" : string - -> val t = (term_of o the o (parse thy)) "fixedValues"; -> val T = type_of t; -val T = "bool List.list => Tools.nam" : typ -> val dsc = dsc_valT t; -val dsc = "nam" : string*) - -(*.from penv in itm_ make args for script depending on type of description.*) -(*6.5.03 TODO: push penv into script -- and drop mk_arg here || drop penv - 9.5.03 penv postponed: penv = env for script at the moment, (*mk_arg*)*) -fun mk_arg thy d [] = raise error ("mk_arg: no data for "^ - (Syntax.string_of_term (thy2ctxt thy) d)) - | mk_arg thy d [t] = - (case dsc_valT d of - "una" => [t] - | "nam" => - [case t of - r as (Const ("op =",_) $ _ $ _) => r - | _ => raise error - ("mk_arg: dsc-typ 'nam' applied to non-equality "^ - (Syntax.string_of_term (thy2ctxt thy) t))] - | s => raise error ("mk_arg: not impl. for "^s)) - - | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts); -(* - val d = d_in itm_; - val [t] = ts_in itm_; -mk_arg thy -*) - - - - -(*.create the actual parameters (args) of script: their order - is given by the order in met.pat .*) -(*WN.5.5.03: ?: does this allow for different descriptions ??? - ?: why not taken from formal args of script ??? -!: FIXXXME penv: push it here in itms2args into script-evaluation*) -(* val (thy, mI, itms) = (thy, metID, itms); - *) -fun itms2args thy mI (itms:itm list) = - let val mvat = max_vt itms - fun okv mvat (_,vats,b,_,_) = member op = vats mvat andalso b - val itms = filter (okv mvat) itms - fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_) - fun itm2arg itms (_,(d,_)) = - case find_first (test_dsc d) itms of - NONE => - raise error ("itms2args: '"^term2str d^"' not in itms") - (*| SOME (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_); - penv postponed; presently penv holds already env for script*) - | SOME (_,_,_,_,itm_) => penvval_in itm_ - fun sel_given_find (s,_) = (s = "#Given") orelse (s = "#Find") - val pats = (#ppc o get_met) mI - in (flat o (map (itm2arg itms))) pats end; -(* -> val sc = ... Solve_root_equation ... -> val mI = ("Script.thy","sqrt-equ-test"); -> val PblObj{meth={ppc=itms,...},...} = get_obj I pt []; -> val ts = itms2args thy mI itms; -> map (Syntax.string_of_term (thy2ctxt thy)) ts; -["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list -*) - - -(*["bool_ (1+x=2)","real_ x"] --match_ags--> oris - --oris2fmz_vals--> ["equality (1+x=2)","boundVariable x","solutions L"]*) -fun oris2fmz_vals oris = - let fun ori2fmz_vals ((_,_,_,dsc,ts):ori) = - ((term2str o comp_dts') (dsc, ts), last_elem ts) - handle _ => raise error ("ori2fmz_env called with "^terms2str ts) - in (split_list o (map ori2fmz_vals)) oris end; - -(*detour necessary, because generate1 delivers a string-result*) -fun mout2term thy (Form' (FormKF (_,_,_,_,res))) = - (term_of o the o (parse (assoc_thy thy))) res - | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl - at time of detection in script*) - -(*.convert a script-tac 'stac' to a tactic 'tac'; if stac is an initac, - then convert to a 'tac_' (as required in appy). - arg pt:ptree for pushing the thy specified in rootpbl into subpbls.*) -fun stac2tac_ pt thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) = -(* val (pt, thy, (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f)) = - (pt, (assoc_thy th), stac); - *) - let val tid = (de_esc_underscore o strip_thy) thmID - in (Rewrite (tid, (string_of_thmI o - (assoc_thm' thy)) (tid,"")), Empty_Tac_) end -(* val (thy, - mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f)) - = (assoc_thy th,stac); - stac2tac_ pt thy mm; - - assoc_thm' (assoc_thy "Isac.thy") (tid,""); - assoc_thm' Isac.thy (tid,""); - *) - | stac2tac_ pt thy (Const ("Script.Rewrite'_Inst",_) $ - sub $ Free (thmID,_) $ _ $ f) = - let val subML = ((map isapair2pair) o isalist2list) sub - val subStr = subst2subs subML - val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*) - in (Rewrite_Inst - (subStr, (tid, (string_of_thmI o - (assoc_thm' thy)) (tid,""))), Empty_Tac_) end - - | stac2tac_ pt thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)= - (Rewrite_Set ((de_esc_underscore o strip_thy) rls), Empty_Tac_) - - | stac2tac_ pt thy (Const ("Script.Rewrite'_Set'_Inst",_) $ - sub $ Free (rls,_) $ _ $ f) = - let val subML = ((map isapair2pair) o isalist2list) sub; - val subStr = subst2subs subML; - in (Rewrite_Set_Inst (subStr,rls), Empty_Tac_) end - - | stac2tac_ pt thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) = - (Calculate op_, Empty_Tac_) - - | stac2tac_ pt thy (Const ("Script.Take",_) $ t) = - (Take (term2str t), Empty_Tac_) - - | stac2tac_ pt thy (Const ("Script.Substitute",_) $ isasub $ arg) = - (Substitute ((subte2sube o isalist2list) isasub), Empty_Tac_) -(* val t = str2term"Substitute [x = L, M_b L = 0] (M_b x = q_0 * x + c)"; - val Const ("Script.Substitute", _) $ isasub $ arg = t; - *) - -(*12.1.01.*) - | stac2tac_ pt thy (Const("Script.Check'_elementwise",_) $ _ $ - (set as Const ("Collect",_) $ Abs (_,_,pred))) = - (Check_elementwise (Syntax.string_of_term (thy2ctxt thy) pred), - (*set*)Empty_Tac_) - - | stac2tac_ pt thy (Const("Script.Or'_to'_List",_) $ _ ) = - (Or_to_List, Empty_Tac_) - -(*12.1.01.for subproblem_equation_dummy in root-equation *) - | stac2tac_ pt thy (Const ("Script.Tac",_) $ Free (str,_)) = - (Tac ((de_esc_underscore o strip_thy) str), Empty_Tac_) - (*L_ will come from pt in appl_in*) - - (*3.12.03 copied from assod SubProblem*) -(* val Const ("Script.SubProblem",_) $ - (Const ("Pair",_) $ - Free (dI',_) $ - (Const ("Pair",_) $ pI' $ mI')) $ ags' = - str2term - "SubProblem (EqSystem_, [linear, system], [no_met])\ - \ [bool_list_ [c_2 = 0, L * c + c_2 = q_0 * L ^^^ 2 / 2],\ - \ real_list_ [c, c_2]]"; -*) - | stac2tac_ pt thy (stac as Const ("Script.SubProblem",_) $ - (Const ("Pair",_) $ - Free (dI',_) $ - (Const ("Pair",_) $ pI' $ mI')) $ ags') = -(*compare "| assod _ (Subproblem'"*) - let val dI = ((implode o drop_last(*.._*) o explode) dI')^".thy"; - val thy = maxthy (assoc_thy dI) (rootthy pt); - val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI'; - val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI'; - val ags = isalist2list ags'; - val (pI, pors, mI) = - if mI = ["no_met"] - then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags) - handle _ =>(match_ags_msg pI stac ags(*raise exn*);[]) - val pI' = refine_ori' pors pI; - in (pI', pors (*refinement over models with diff.prec only*), - (hd o #met o get_pbt) pI') end - else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags) - handle _ => (match_ags_msg pI stac ags(*raise exn*); []), - mI); - val (fmz_, vals) = oris2fmz_vals pors; - val {cas,ppc,thy,...} = get_pbt pI - val dI = theory2theory' thy (*.take dI from _refined_ pbl.*) - val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt)); - val hdl = case cas of - NONE => pblterm dI pI - | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t - val f = subpbl (strip_thy dI) pI - in (Subproblem (dI, pI), - Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f)) - end - - | stac2tac_ pt thy t = raise error - ("stac2tac_ TODO: no match for "^ - (Syntax.string_of_term (thy2ctxt thy) t)); -(* -> val t = (term_of o the o (parse thy)) - "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)"; -> stac2tac_ pt t; -val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : tac - -> val t = (term_of o the o (parse SqRoot.thy)) -"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\ - \ [bool_ e_, real_ v_])::bool list"; -> stac2tac_ pt SqRoot.thy t; -val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #))) -*) - -fun stac2tac pt thy t = (fst o stac2tac_ pt thy) t; - - - - -(*test a term for being a _list_ (set ?) of constants; could be more rigorous*) -fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true - | list_of_consts (Const ("List.list.Nil",_)) = true - | list_of_consts _ = false; -(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]"; -> list_of_consts ttt; -val it = true : bool -> val ttt = (term_of o the o (parse thy)) "[]"; -> list_of_consts ttt; -val it = true : bool*) - - - - - -(* 15.1.01: evaluation of preds only works occasionally, - but luckily for the 2 examples of root-equ: -> val s = ((term_of o the o (parse thy)) "x", - (term_of o the o (parse thy)) "-#5//#12"); -> val asm = (term_of o the o (parse thy)) - "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)"; -> val pred = subst_atomic [s] asm; -> rewrite_set_ thy false ((cterm_of thy) pred); -val it = NONE : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!! -> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred); -val it = false : bool - -> val s = ((term_of o the o (parse thy)) "x", - (term_of o the o (parse thy)) "#4"); -> val asm = (term_of o the o (parse thy)) - "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)"; -> val pred = subst_atomic [s] asm; -> rewrite_set_ thy false ((cterm_of thy) pred); -val it = SOME ("True & True",[]) : (cterm * cterm list) option -> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred); -val it = true : bool`*) - -(*for check_elementwise: take apart the set, ev. instantiate assumptions -fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) = - let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set; - val bdv = Free (bdv,T); - val pred = if pred <> Const ("Script.Assumptions",bool) - then pred - else (mk_and o (map fst)) (get_assumptions_ pt (p,Res)) - in (bdv, pred) end - | rep_set thy _ _ set = - raise error ("check_elementwise: no set "^ (*from script*) - (Syntax.string_of_term (thy2ctxt thy) set)); -(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}"; -> val p = []; -> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]), - ("#0 <= #9 + #4 * x",[22]), - ("#0 <= x ^^^ #2 + #5 * x",[33]), - ("#0 <= #2 + x",[44])]; -> val (bdv,pred) = rep_set thy pt p set; -val bdv = Free ("x","RealDef.real") : term -> writeln (Syntax.string_of_term (thy2ctxt thy) pred); -((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & - #0 <= x ^^^ #2 + #5 * x) & -#0 <= #2 + x -*) ---------------------------------------------11.6.03--was unused*) - - - - -datatype ass = - Ass of tac_ * (*SubProblem gets args instantiated in assod*) - term (*for itr_arg,result in ets*) -| AssWeak of tac_ * - term (*for itr_arg,result in ets*) -| NotAss; - -(*.assod: tac_ associated with stac w.r.t. d -args - pt:ptree for pushing the thy specified in rootpbl into subpbls -returns - Ass : associated: e.g. thmID in stac = thmID in m - +++ arg in stac = arg in m - AssWeak: weakly ass.:e.g. thmID in stac = thmID in m, //arg// - NotAss : e.g. thmID in stac/=/thmID in m (not =) -8.01: - tac_ SubProblem with args completed from script -.*) -fun assod pt d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) stac = - (case stac of - (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $b$f_)=> - if thmID = thmID_ then - if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f')) - else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f')) - else ((*writeln"3### assod ..NotAss";*)NotAss) - | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $_$f_)=> - if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - | _ => NotAss) - - | assod pt d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm))) stac = - (case stac of - (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) => - ((*writeln("3### assod: stac = "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)); - writeln("3### assod: f(m)= "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) f));*) - if thmID = thmID_ then - if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f')) - else ((*writeln"### assod ..AssWeak"; - writeln("### assod: f(m) = "^ - (Sign.string_of_term (sign_of(assoc_thy thy)) f)); - writeln("### assod: f(stac)= "^ - (Sign.string_of_term(sign_of(assoc_thy thy))f_))*) - AssWeak (m,f')) - else ((*writeln"3### assod ..NotAss";*)NotAss)) - | (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) => - if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - | _ => NotAss) - -(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0"; -> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0"; -> val m = Rewrite'("Script.thy","tless_true","eval_rls",false, - ("rroot_square_inv",""),f,(f',[])); -> val stac = (term_of o the o (parse thy)) - "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)"; -> assod e_rls m stac; -val it = - (SOME (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"), - Const ("empty","RealDef.real")) : tac_ option * term * term*) - - | assod pt d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm))) - (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)= - if id_rls rls = rls_ then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - - | assod pt d (m as Detail_Set_Inst' (thy',put,sub,rls,f,(f',asm))) - (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)= - if id_rls rls = rls_ then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - - | assod pt d (m as Rewrite_Set' (thy,put,rls,f,(f',asm))) - (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) = - if id_rls rls = rls_ then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - - | assod pt d (m as Detail_Set' (thy,put,rls,f,(f',asm))) - (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) = - if id_rls rls = rls_ then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - - | assod pt d (m as Calculate' (thy',op_,f,(f',thm'))) stac = - (case stac of - (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) => - if op_ = op__ then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free(rls_,_) $_$f_)=> - if contains_rule (Calc (snd (assoc1 (!calclist', op_)))) - (assoc_rls rls_) then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - | (Const ("Script.Rewrite'_Set",_) $ Free (rls_, _) $ _ $ f_) => - if contains_rule (Calc (snd (assoc1 (!calclist', op_)))) - (assoc_rls rls_) then - if f = f_ then Ass (m,f') else AssWeak (m,f') - else NotAss - | _ => NotAss) - - | assod pt _ (m as Check_elementwise' (consts,_,(consts_chkd,_))) - (Const ("Script.Check'_elementwise",_) $ consts' $ _) = - ((*writeln("### assod Check'_elementwise: consts= "^(term2str consts)^ - ", consts'= "^(term2str consts')); - atomty consts; atomty consts';*) - if consts = consts' then ((*writeln"### assod Check'_elementwise: Ass";*) - Ass (m, consts_chkd)) - else ((*writeln"### assod Check'_elementwise: NotAss";*) NotAss)) - - | assod pt _ (m as Or_to_List' (ors, list)) - (Const ("Script.Or'_to'_List",_) $ _) = - Ass (m, list) - - | assod pt _ (m as Take' term) - (Const ("Script.Take",_) $ _) = - Ass (m, term) - - | assod pt _ (m as Substitute' (_, _, res)) - (Const ("Script.Substitute",_) $ _ $ _) = - Ass (m, res) -(* val t = str2term "Substitute [(x, 3)] (x^^^2 + x + 1)"; - val (Const ("Script.Substitute",_) $ _ $ _) = t; - *) - - | assod pt _ (m as Tac_ (thy,f,id,f')) - (Const ("Script.Tac",_) $ Free (id',_)) = - if id = id' then Ass (m, ((term_of o the o (parse thy)) f')) - else NotAss - - -(* val t = str2term - "SubProblem (DiffApp_,[make,function],[no_met]) \ - \[real_ m_, real_ v_, bool_list_ rs_]"; - - val (Subproblem' ((domID,pblID,metID),_,_,_,f)) = m; - val (Const ("Script.SubProblem",_) $ - (Const ("Pair",_) $ - Free (dI',_) $ - (Const ("Pair",_) $ pI' $ mI')) $ ags') = stac; - *) - | assod pt _ (Subproblem' ((domID,pblID,metID),_,_,_,f)) - (stac as Const ("Script.SubProblem",_) $ - (Const ("Pair",_) $ - Free (dI',_) $ - (Const ("Pair",_) $ pI' $ mI')) $ ags') = -(*compare "| stac2tac_ thy (Const ("Script.SubProblem",_)"*) - let val dI = ((implode o drop_last o explode) dI')^".thy"; - val thy = maxthy (assoc_thy dI) (rootthy pt); - val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI'; - val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI'; - val ags = isalist2list ags'; - val (pI, pors, mI) = - if mI = ["no_met"] - then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags) - handle _=>(match_ags_msg pI stac ags(*raise exn*);[]); - val pI' = refine_ori' pors pI; - in (pI', pors (*refinement over models with diff.prec only*), - (hd o #met o get_pbt) pI') end - else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags) - handle _ => (match_ags_msg pI stac ags(*raise exn*);[]), - mI); - val (fmz_, vals) = oris2fmz_vals pors; - val {cas, ppc,...} = get_pbt pI - val {cas, ppc, thy,...} = get_pbt pI - val dI = theory2theory' thy (*take dI from _refined_ pbl*) - val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt)) - val hdl = case cas of - NONE => pblterm dI pI - | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t - val f = subpbl (strip_thy dI) pI - in if domID = dI andalso pblID = pI - then Ass (Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f), f) - else NotAss - end - - | assod pt d m t = - (if (!trace_script) - then writeln("@@@ the 'tac_' proposed to apply does NOT match the leaf found in the script:\n"^ - "@@@ tac_ = "^(tac_2str m)) - else (); - NotAss); - - - -fun tac_2tac (Refine_Tacitly' (pI,_,_,_,_)) = Refine_Tacitly pI - | tac_2tac (Model_Problem' (pI,_,_)) = Model_Problem - | tac_2tac (Add_Given' (t,_)) = Add_Given t - | tac_2tac (Add_Find' (t,_)) = Add_Find t - | tac_2tac (Add_Relation' (t,_)) = Add_Relation t - - | tac_2tac (Specify_Theory' dI) = Specify_Theory dI - | tac_2tac (Specify_Problem' (dI,_)) = Specify_Problem dI - | tac_2tac (Specify_Method' (dI,_,_)) = Specify_Method dI - - | tac_2tac (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) = - Rewrite (thmID,thm) - - | tac_2tac (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))= - Rewrite_Inst (subst2subs sub,(thmID,thm)) - - | tac_2tac (Rewrite_Set' (thy,put,rls,f,(f',asm))) = - Rewrite_Set (id_rls rls) - - | tac_2tac (Detail_Set' (thy,put,rls,f,(f',asm))) = - Detail_Set (id_rls rls) - - | tac_2tac (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) = - Rewrite_Set_Inst (subst2subs sub,id_rls rls) - - | tac_2tac (Detail_Set_Inst' (thy,put,sub,rls,f,(f',asm))) = - Detail_Set_Inst (subst2subs sub,id_rls rls) - - | tac_2tac (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_) - - | tac_2tac (Check_elementwise' (consts,pred,consts')) = - Check_elementwise pred - - | tac_2tac (Or_to_List' _) = Or_to_List - | tac_2tac (Take' term) = Take (term2str term) - | tac_2tac (Substitute' (subte, t, res)) = Substitute (subte2sube subte) - - | tac_2tac (Tac_ (_,f,id,f')) = Tac id - - | tac_2tac (Subproblem' ((domID, pblID, _), _, _,_,_)) = - Subproblem (domID, pblID) - | tac_2tac (Check_Postcond' (pblID, _)) = - Check_Postcond pblID - | tac_2tac Empty_Tac_ = Empty_Tac - - | tac_2tac m = - raise error ("tac_2tac: not impl. for "^(tac_2str m)); - - - - -(** decompose tac_ to a rule and to (lhs,rhs) - unly needed ~~~ **) - -val idT = Type ("Script.ID",[]); -(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID"; -type_of tt = idT; -val it = true : bool -*) - -fun make_rule thy t = - let val ct = cterm_of thy (Trueprop $ t) - in Thm (Syntax.string_of_term (thy2ctxt thy) (term_of ct), make_thm ct) end; - -(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m; - *) -(*decompose tac_ to a rule and to (lhs,rhs) for ets FIXME.12.03: obsolete! - NOTE.12.03: also used for msg 'not locatable' ?!: 'Subproblem' missing !!! -WN0508 only use in tac_2res, which uses only last return-value*) -fun rep_tac_ (Rewrite_Inst' - (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) = - let val fT = type_of f; - val b = if put then HOLogic.true_const else HOLogic.false_const; - val sT = (type_of o fst o hd) subs; - val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) - (map HOLogic.mk_prod subs); - val sT' = type_of subs'; - val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT) - $ subs' $ Free (thmID,idT) $ b $ f; - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end -(*Fehlersuche 25.4.01 -(a)----- als String zusammensetzen: -ML> Syntax.string_of_term (thy2ctxt thy)f; -val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string -ML> Syntax.string_of_term (thy2ctxt thy)f'; -val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string -ML> subs; -val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst -> val tt = (term_of o the o (parse thy)) - "(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))"; -> atomty tt; -ML> writeln(Syntax.string_of_term (thy2ctxt thy)tt); -(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) - -(b)----- laut rep_tac_: -> val ttt=HOLogic.mk_eq (lhs,f'); -> atomty ttt; - - -(*Fehlersuche 1-2Monate vor 4.01:*) -> val tt = (term_of o the o (parse thy)) - "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)"; -> atomty tt; - -> val f = (term_of o the o (parse thy)) "x=#1+#2"; -> val f' = (term_of o the o (parse thy)) "x=#3"; -> val subs = [((term_of o the o (parse thy)) "bdv", - (term_of o the o (parse thy)) "x")]; -> val sT = (type_of o fst o hd) subs; -> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) - (map HOLogic.mk_prod subs); -> val sT' = type_of subs'; -> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT) - $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f; -> lhs = tt; -val it = true : bool -> rep_tac_ (Rewrite_Inst' - ("Script.thy","tless_true","eval_rls",false,subs, - ("square_equation_left",""),f,(f',[]))); -*) - | rep_tac_ (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))= - let - val fT = type_of f; - val b = if put then HOLogic.true_const else HOLogic.false_const; - val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT) - $ Free (thmID,idT) $ b $ f; - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end -(* -> val tt = (term_of o the o (parse thy)) (*____ ____..test*) - "Rewrite square_equation_left True (x=#1+#2) = (x=#3)"; - -> val f = (term_of o the o (parse thy)) "x=#1+#2"; -> val f' = (term_of o the o (parse thy)) "x=#3"; -> val Thm (id,thm) = - rep_tac_ (Rewrite' - ("Script.thy","tless_true","eval_rls",false, - ("square_equation_left",""),f,(f',[]))); -> val SOME ct = parse thy - "Rewrite square_equation_left True (x=#1+#2)"; -> rewrite_ Script.thy tless_true eval_rls true thm ct; -val it = SOME ("x = #3",[]) : (cterm * cterm list) option -*) - | rep_tac_ (Rewrite_Set_Inst' - (thy',put,subs,rls,f,(f',asm))) = - (e_rule, (e_term, f')) -(*WN050824: type error ... - let val fT = type_of f; - val sT = (type_of o fst o hd) subs; - val subs' = list2isalist (HOLogic.mk_prodT (sT, sT)) - (map HOLogic.mk_prod subs); - val sT' = type_of subs'; - val b = if put then HOLogic.true_const else HOLogic.false_const - val lhs = Const ("Script.Rewrite'_Set'_Inst", - [sT',idT,fT,fT] ---> fT) - $ subs' $ Free (id_rls rls,idT) $ b $ f; - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end*) -(* ... vals from Rewrite_Inst' ... -> rep_tac_ (Rewrite_Set_Inst' - ("Script.thy",false,subs, - "isolate_bdv",f,(f',[]))); -*) -(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m; -*) - | rep_tac_ (Rewrite_Set' (thy',put,rls,f,(f',asm)))= - let val fT = type_of f; - val b = if put then HOLogic.true_const else HOLogic.false_const; - val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT) - $ Free (id_rls rls,idT) $ b $ f; - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end -(* 13.3.01: -val thy = assoc_thy thy'; -val t = HOLogic.mk_eq (lhs,f'); -make_rule thy t; --------------------------------------------------- -val lll = (term_of o the o (parse thy)) - "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)"; - --------------------------------------------------- -> val f = (term_of o the o (parse thy)) "x=#1+#2"; -> val f' = (term_of o the o (parse thy)) "x=#3"; -> val Thm (id,thm) = - rep_tac_ (Rewrite_Set' - ("Script.thy",false,"SqRoot_simplify",f,(f',[]))); -val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string -val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm -*) - | rep_tac_ (Calculate' (thy',op_,f,(f',thm')))= - let val fT = type_of f; - val lhs = Const ("Script.Calculate",[idT,fT] ---> fT) - $ Free (op_,idT) $ f - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end -(* -> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)"; - ... test-root-equ.sml: calculate ... -> val Appl m'=applicable_in p pt (Calculate "PLUS"); -> val (lhs,_)=tac_2etac m'; -> lhs'=lhs; -val it = true : bool*) - | rep_tac_ (Check_elementwise' (t,str,(t',asm))) = (Erule, (e_term, t')) - | rep_tac_ (Subproblem' (_,_,_,_,t')) = (Erule, (e_term, t')) - | rep_tac_ (Take' (t')) = (Erule, (e_term, t')) - | rep_tac_ (Substitute' (subst,t,t')) = (Erule, (t, t')) - | rep_tac_ (Or_to_List' (t, t')) = (Erule, (t, t')) - | rep_tac_ m = raise error ("rep_tac_: not impl.for "^ - (tac_2str m)); - -(*"N.3.6.03------ -fun tac_2rule m = (fst o rep_tac_) m; -fun tac_2etac m = (snd o rep_tac_) m; -fun tac_2tac m = (fst o snd o rep_tac_) m;*) -fun tac_2res m = (snd o snd o rep_tac_) m;(*ONLYuse of rep_tac_ - FIXXXXME: simplify rep_tac_*) - - -(*.handle a leaf; - a leaf is either a tactic or an 'exp' in 'let v = expr' - where 'exp' does not contain a tactic. - handling a leaf comprises - (1) 'subst_stacexpr' substitute env and complete curried tactic - (2) rewrite the leaf by 'srls' -WN060906 quick and dirty fix: return a' too (for updating E later) -.*) -fun handle_leaf call thy srls E a v t = - (*WN050916 'upd_env_opt' is a blind copy from previous version*) - case subst_stacexpr E a v t of - (a', STac stac) => (*script-tactic*) - let val stac' = eval_listexpr_ (assoc_thy thy) srls - (subst_atomic (upd_env_opt E (a,v)) stac) - in (if (!trace_script) - then writeln ("@@@ "^call^" leaf '"^term2str t^"' ---> STac '"^ - term2str stac'^"'") - else (); - (a', STac stac')) - end - | (a', Expr lexpr) => (*leaf-expression*) - let val lexpr' = eval_listexpr_ (assoc_thy thy) srls - (subst_atomic (upd_env_opt E (a,v)) lexpr) - in (if (!trace_script) - then writeln("@@@ "^call^" leaf '"^term2str t^"' ---> Expr '"^ - term2str lexpr'^"'") - else (); - (a', Expr lexpr')) - end; - - - -(** locate an applicable stactic in a script **) - -datatype assoc = (*ExprVal in the sense of denotational semantics*) - Assoc of (*the stac is associated, strongly or weakly*) - scrstate * (*the current; returned for next_tac etc. outside ass* *) - (step list) (*list of steps done until associated stac found; - initiated with the data for doing the 1st step, - thus the head holds these data further on, - while the tail holds steps finished (incl.scrstate in ptree)*) -| NasApp of (*stac not associated, but applicable, ptree-node generated*) - scrstate * (step list) -| NasNap of (*stac not associated, not applicable, nothing generated; - for distinction in Or, for leaving iterations, leaving Seq, - evaluate scriptexpressions*) - term * env; -fun assoc2str (Assoc _) = "Assoc" - | assoc2str (NasNap _) = "NasNap" - | assoc2str (NasApp _) = "NasApp"; - - -datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*) - Aundef (*undefined: set only by (topmost) Or*) -| AssOnly (*do not execute appl stacs - there could be an associated - in parallel Or-branch*) -| AssGen; (*no Ass(Weak) found within Or, thus - search for _applicable_ stacs, execute and generate pt*) -(*this constructions doesnt allow arbitrary nesting of Or !!!*) - - -(*assy, ass_up, astep_up scanning for locate_gen at stactic in a script. - search is clearly separated into (1)-(2): - (1) assy is recursive descent; - (2) ass_up resumes interpretation at a location somewhere in the script; - astep_up does only get to the parentnode of the scriptexpr. - consequence: - * call of (2) means _always_ that in this branch below - there was an appl.stac (Repeat, Or e1, ...) -*) -fun assy ya (is as (E,l,a,v,S,b),ss) - (Const ("Let",_) $ e $ (Abs (id,T,body))) = -(* val (ya, (is as (E,l,a,v,S,b),ss),Const ("Let",_) $ e $ (Abs (id,T,body))) = - (*1*)(((ts,d),Aundef), ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]), body); - *) - ((*writeln("### assy Let$e$Abs: is="); - writeln(istate2str (ScrState is));*) - case assy ya ((E , l@[L,R], a,v,S,b),ss) e of - NasApp ((E',l,a,v,S,bb),ss) => - let val id' = mk_Free (id, T); - val E' = upd_env E' (id', v); - (*val _=writeln("### assy Let -> NasApp");*) - in assy ya ((E', l@[R,D], a,v,S,b),ss) body end - | NasNap (v,E) => - let val id' = mk_Free (id, T); - val E' = upd_env E (id', v); - (*val _=writeln("### assy Let -> NasNap");*) - in assy ya ((E', l@[R,D], a,v,S,b),ss) body end - | ay => ay) - - | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss) - (Const ("Script.While",_) $ c $ e $ a) = - ((*writeln("### assy While $ c $ e $ a, upd_env= "^ - (subst2str (upd_env E (a,v))));*) - if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c) - then assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e - else NasNap (v, E)) - - | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss) - (Const ("Script.While",_) $ c $ e) = - ((*writeln("### assy While, l= "^(loc_2str l));*) - if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c) - then assy ya ((E, l@[R], a,v,S,b),ss) e - else NasNap (v, E)) - - | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss) - (Const ("If",_) $ c $ e1 $ e2) = - (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c) - then assy ya ((E, l@[L,R], a,v,S,b),ss) e1 - else assy ya ((E, l@[ R], a,v,S,b),ss) e2) - - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) = - ((*writeln("### assy Try $ e $ a, l= "^(loc_2str l));*) - case assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e of - ay => ay) - - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) = - ((*writeln("### assy Try $ e, l= "^(loc_2str l));*) - case assy ya ((E, l@[R], a,v,S,b),ss) e of - ay => ay) -(* val (ya, ((E,l,_,v,S,b),ss), (Const ("Script.Seq",_) $e1 $ e2 $ a)) = - (*2*)(ya, ((E , l@[L,R], a,v,S,b),ss), e); - *) - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) = - ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*) - case assy ya ((E, l@[L,L,R], SOME a,v,S,b),ss) e1 of - NasNap (v, E) => assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2 - | NasApp ((E,_,_,v,_,_),ss) => - assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2 - | ay => ay) - - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) = - (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of - NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2 - | NasApp ((E,_,_,v,_,_),ss) => - assy ya ((E, l@[R], a,v,S,b),ss) e2 - | ay => ay) - - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) = - assy ya ((E,(l@[L,R]),SOME a,v,S,b),ss) e - - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) = - assy ya ((E,(l@[R]),a,v,S,b),ss) e - -(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*) - | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) = - (case assy (y, AssOnly) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of - NasNap (v, E) => - (case assy (y, AssOnly) ((E,(l@[L,R]),SOME a,v,S,b),ss) e2 of - NasNap (v, E) => - (case assy (y, AssGen) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of - NasNap (v, E) => - assy (y, AssGen) ((E, (l@[L,R]), SOME a,v,S,b),ss) e2 - | ay => ay) - | ay =>(ay)) - | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///") - | ay => (ay)) - - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) = - (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of - NasNap (v, E) => - assy ya ((E,(l@[R]),a,v,S,b),ss) e2 - | ay => (ay)) -(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])]; - val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False"; - - val (ap,(p,p_),c,ss) = (Aundef,p,[],[]); - assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,EmptyMout,pt,(p,p_),c)::ss) t; -val ((((thy',sr),d),ap), (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss), t) = - (); - *) - - | assy (((thy',sr),d),ap) (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t = - ((*writeln("### assy, m = "^tac_2str m); - writeln("### assy, (p,p_) = "^pos'2str (p,p_)); - writeln("### assy, is= "); - writeln(istate2str (ScrState is));*) - case handle_leaf "locate" thy' sr E a v t of - (a', Expr s) => - ((*writeln("### assy: listexpr t= "^(term2str t)); - writeln("### assy, E= "^(env2str E)); - writeln("### assy, eval(..)= "^(term2str - (eval_listexpr_ (assoc_thy thy') sr - (subst_atomic (upd_env_opt E (a',v)) t))));*) - NasNap (eval_listexpr_ (assoc_thy thy') sr - (subst_atomic (upd_env_opt E (a',v)) t), E)) - (* val (_,STac stac) = subst_stacexpr E a v t; - *) - | (a', STac stac) => - let (*val _=writeln("### assy, stac = "^term2str stac);*) - val p' = case p_ of Frm => p | Res => lev_on p - | _ => raise error ("assy: call by "^ - (pos'2str (p,p_))); - in case assod pt d m stac of - Ass (m,v') => - let (*val _=writeln("### assy: Ass ("^tac_2str m^", "^ - term2str v'^")");*) - val (p'',c',f',pt') = generate1 (assoc_thy thy') m - (ScrState (E,l,a',v',S,true)) (p',p_) pt; - in Assoc ((E,l,a',v',S,true), (m,f',pt',p'',c @ c')::ss) end - | AssWeak (m,v') => - let (*val _=writeln("### assy: Ass Weak("^tac_2str m^", "^ - term2str v'^")");*) - val (p'',c',f',pt') = generate1 (assoc_thy thy') m - (ScrState (E,l,a',v',S,false)) (p',p_) pt; - in Assoc ((E,l,a',v',S,false), (m,f',pt',p'',c @ c')::ss) end - | NotAss => - ((*writeln("### assy, NotAss");*) - case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*) - AssOnly => (NasNap (v, E)) - | gen => (case applicable_in (p,p_) pt - (stac2tac pt (assoc_thy thy') stac) of - Appl m' => - let val is = (E,l,a',tac_2res m',S,false(*FIXXXME*)) - val (p'',c',f',pt') = - generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt; - in NasApp (is,(m,f',pt',p'',c @ c')::ss) end - | Notappl _ => - (NasNap (v, E)) - ) - ) - end); -(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e; - *) - - -(* val (ys as (y,s,Script sc,d),(is as (E,l,a,v,S,b),ss),Const ("Let",_) $ _) = - (ys, ((E,up,a,v,S,b),ss), go up sc); - *) -fun ass_up (ys as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss) - (Const ("Let",_) $ _) = - let (*val _= writeln("### ass_up1 Let$e: is=") - val _= writeln(istate2str (ScrState is))*) - val l = drop_last l; (*comes from e, goes to Abs*) - val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc; - val i = mk_Free (i, T); - val E = upd_env E (i, v); - (*val _=writeln("### ass_up2 Let$e: E="^(subst2str E));*) - in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of - Assoc iss => Assoc iss - | NasApp iss => astep_up ys iss - | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end - - | ass_up ys (iss as (is,_)) (Abs (_,_,_)) = - ((*writeln("### ass_up Abs: is="); - writeln(istate2str (ScrState is));*) - astep_up ys iss) (*TODO 5.9.00: env ?*) - - | ass_up ys (iss as (is,_)) (Const ("Let",_) $ e $ (Abs (i,T,b)))= - ((*writeln("### ass_up Let $ e $ Abs: is="); - writeln(istate2str (ScrState is));*) - astep_up ys iss) (*TODO 5.9.00: env ?*) - - (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _ $ _)) = - (ys, ((E,up,a,v,S,b),ss), (go up sc)); - *) - | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) = - astep_up ysa iss (*all has been done in (*2*) below*) - - | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) = - (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _)) = - (ys, ((E,up,a,v,S,b),ss), (go up sc)); - *) - astep_up ysa iss (*2*: comes from e2*) - - | ass_up (ysa as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss) - (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*) - (* val ((ysa as (y,s,Script sc,d)), (is as (E,l,a,v,S,b),ss), - (Const ("Script.Seq",_) $ _ )) = - (ys, ((E,up,a,v,S,b),ss), (go up sc)); - *) - let val up = drop_last l; - val Const ("Script.Seq",_) $ _ $ e2 = go up sc - (*val _= writeln("### ass_up Seq$e: is=") - val _= writeln(istate2str (ScrState is))*) - in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of - NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss) - | NasApp iss => astep_up ysa iss - | ay => ay end - - (* val (ysa, iss, (Const ("Script.Try",_) $ e $ _)) = - (ys, ((E,up,a,v,S,b),ss), (go up sc)); - *) - | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) = - astep_up ysa iss - - (* val (ysa, iss, (Const ("Script.Try",_) $ e)) = - (ys, ((E,up,a,v,S,b),ss), (go up sc)); - *) - | ass_up ysa iss (Const ("Script.Try",_) $ e) = - ((*writeln("### ass_up Try $ e");*) - astep_up ysa iss) - - | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss) - (*(Const ("Script.While",_) $ c $ e $ a) = WN050930 blind fix*) - (t as Const ("Script.While",_) $ c $ e $ a) = - ((*writeln("### ass_up: While c= "^ - (term2str (subst_atomic (upd_env E (a,v)) c)));*) - if eval_true_ y s (subst_atomic (upd_env E (a,v)) c) - then (case assy (((y,s),d),Aundef) ((E, l@[L,R], SOME a,v,S,b),ss) e of - NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss) - | NasApp ((E',l,a,v,S,b),ss) => - ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*) - | ay => ay) - else astep_up ys ((E,l, SOME a,v,S,b),ss) - ) - - | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss) - (*(Const ("Script.While",_) $ c $ e) = WN050930 blind fix*) - (t as Const ("Script.While",_) $ c $ e) = - if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c) - then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of - NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss) - | NasApp ((E',l,a,v,S,b),ss) => - ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*) - | ay => ay) - else astep_up ys ((E,l, a,v,S,b),ss) - - | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss - - | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss) - (t as Const ("Script.Repeat",_) $ e $ a) = - (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), SOME a,v,S,b),ss) e of - NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss) - | NasApp ((E',l,a,v,S,b),ss) => - ass_up ys ((E',l,a,v,S,b),ss) t - | ay => ay) - - | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss)) - (t as Const ("Script.Repeat",_) $ e) = - (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of - NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss) - | NasApp ((E',l,a,v',S,bb),ss) => - ass_up ys ((E',l,a,v',S,b),ss) t - | ay => ay) - - | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss - - | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss - - | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) = - astep_up y ((E, (drop_last l), a,v,S,b),ss) - - | ass_up y iss t = - raise error ("ass_up not impl for t= "^(term2str t)) -(* 9.6.03 - val (ys as (_,_,Script sc,_), ss) = - ((thy',srls,scr,d), [(m,EmptyMout,pt,p,[])]:step list); - astep_up ys ((E,l,a,v,S,b),ss); - val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) = - (ysa, iss); - val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) = - ((thy',srls,scr,d), ((E,l,a,v,S,b), [(m,EmptyMout,pt,p,[])])); - *) -and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) = - if 1 < length l - then - let val up = drop_last l; - (*val _= writeln("### astep_up: E= "^env2str E);*) - in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end - else (NasNap (v, E)) -; - - - - - -(* use"ME/script.sml"; - use"script.sml"; - term2str (go up sc); - - *) - -(*check if there are tacs for rewriting only*) -fun rew_only ([]:step list) = true - | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss - | rew_only _ = false; - - -datatype locate = - Steps of istate (*producing hd of step list (which was latest) - for next_tac, for reporting Safe|Unsafe to DG*) - * step (*(scrstate producing this step is in ptree !)*) - list (*locate_gen may produce intermediate steps*) -| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*) - - - -(* locate_gen tries to locate an input tac m in the script. - pursuing this goal the script is executed until an (m' equiv m) is found, - or the end of the script -args - m : input by the user, already checked by applicable_in, - (to be searched within Or; and _not_ an m doing the step on ptree !) - p,pt: (incl ets) at the time of input - scr : the script - d : canonical simplifier for locating Take, Substitute, Subproblems etc. - ets : ets at the time of input - l : the location (in scr) of the stac which generated the current formula -returns - Steps: pt,p (incl. ets) with m done - pos' list of proofobjs cut (from generate) - safe: implied from last proofobj - ets: - ///ToDo : ets contains a list of tacs to be done before m can be done - NOT IMPL. -- "error: do other step before" - NotLocatable: thus generate_hard -*) -(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...}, - RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is); - *) -fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p) - (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) = - (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of - [] => NotLocatable - | rts' => - Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts')) -(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is; - locate_gen (thy':theory') (m:tac_) ((pt,p):ptree * pos') - (scr,d) (E,l,a,v,S,bb); - 9.6.03 - val ts = (thy',srls); - val p = (p,p_); - val (scr as Script (h $ body)) = (sc); - val ScrState (E,l,a,v,S,b) = (is); - - val (ts as (thy',srls), m, (pt,p), - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = - ((thy',srls), m, (pt,(p,p_)), (sc,d), is); - locate_gen (thy',srls) m (pt,p) (Script(h $ body),d)(ScrState(E,l,a,v,S,b)); - - val (ts as (thy',srls), m, (pt,p), - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = - ((thy',srls), m', (pt,(lev_on p,Frm)), (sc,d), is'); - - val (ts as (thy',srls), m, (pt,p), - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = - ((thy',srls), m', (pt,(p, Res)), (sc,d), is'); - - val (ts as (thy',srls), m, (pt,p), - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) = - ((thy',srls), m, (pt,(p,p_)), (sc,d), is); - *) - | locate_gen (ts as (thy',srls)) (m:tac_) ((pt,p):ptree * pos') - (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) = - let (*val _= writeln("### locate_gen-----------------: is="); - val _= writeln( istate2str (ScrState (E,l,a,v,S,b))); - val _= writeln("### locate_gen: l= "^loc_2str l^", p= "^pos'2str p)*) - val thy = assoc_thy thy'; - in case if l=[] orelse ((*init.in solve..Apply_Method...*) - (last_elem o fst) p = 0 andalso snd p = Res) - then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b), - [(m,EmptyMout,pt,p,[])]) body) -(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) = - (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])); - (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]) body); - *) - else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b), - [(m,EmptyMout,pt,p,[])]) ) of - Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) => -(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) = - (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b), - [(m,EmptyMout,pt,p,[])]) ); - *) - ((*writeln("### locate_gen Assoc: p'="^(pos'2str p'));*) - if bb then Steps (ScrState is, ss) - else if rew_only ss (*andalso 'not bb'= associated weakly*) - then let val (po,p_) = p - val po' = case p_ of Frm => po | Res => lev_on po - (*WN.12.03: noticed, that pos is also updated in assy !?! - instead take p' from Assoc ?????????????????????????????*) - val (p'',c'',f'',pt'') = - generate1 thy m (ScrState is) (po',p_) pt; - (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*) - (*drop the intermediate steps !*) - in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end - else Steps (ScrState is, ss)) - - | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] => - raise error ("locate_gen: should not have got NasApp, ets =")*) - => NotLocatable - | NasNap (_,_) => - if l=[] then NotLocatable - else (*scan from begin of script for rew_only*) - (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b), - [(m,EmptyMout,pt,p,[])]) body of - Assoc (iss as (is as (_,_,_,_,_,bb), - ss as ((m',f',pt',p',c')::_))) => - ((*writeln"4### locate_gen Assoc after Fini";*) - if rew_only ss - then let val(p'',c'',f'',pt'') = - generate1 thy m (ScrState is) p' pt; - (*drop the intermediate steps !*) - in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end - else NotLocatable) - | _ => ((*writeln ("#### locate_gen: after Fini");*) - NotLocatable)) - end - | locate_gen _ m _ (sc,_) is = - raise error ("locate_gen: wrong arguments,\n tac= "^(tac_2str m)^ - ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is)); - - - -(** find the next stactic in a script **) - -datatype appy = (*ExprVal in the sense of denotational semantics*) - Appy of (*applicable stac found, search stalled*) - tac_ * (*tac_ associated (fun assod) with stac*) - scrstate (*after determination of stac WN.18.8.03*) - | Napp of (*stac found was not applicable; - this mode may become Skip in Repeat, Try and Or*) - env (*stack*) (*popped while nxt_up*) - | Skip of (*for restart after Appy, for leaving iterations, - for passing the value of scriptexpressions, - and for finishing the script successfully*) - term * env (*stack*); - -(*appy, nxt_up, nstep_up scanning for next_tac. - search is clearly separated into (1)-(2): - (1) appy is recursive descent; - (2) nxt_up resumes interpretation at a location somewhere in the script; - nstep_up does only get to the parentnode of the scriptexpr. - consequence: - * call of (2) means _always_ that in this branch below - there was an applicable stac (Repeat, Or e1, ...) -*) - - -datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*) - (* Appy is only (final) returnvalue, not argument during search - |*) Napp_ (*ev. detects 'script is not appropriate for this example'*) - | Skip_; (*detects 'script successfully finished' - also used as init-value for resuming; this works, - because 'nxt_up Or e1' treats as Appy*) - -fun appy thy ptp E l - (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v = -(* val (thy, ptp, E, l, t as Const ("Let",_) $ e $ (Abs (i,T,b)),a, v)= - (thy, ptp, E, up@[R,D], body, a, v); - appy thy ptp E l t a v; - *) - ((*writeln("### appy Let$e$Abs: is="); - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) - case appy thy ptp E (l@[L,R]) e a v of - Skip (res, E) => - let (*val _= writeln("### appy Let "^(term2str t)); - val _= writeln("### appy Let: Skip res ="^(term2str res));*) - (*val (i',b') = variant_abs (i,T,b); WN.15.5.03 - val i = mk_Free(i',T); WN.15.5.03 *) - val E' = upd_env E (Free (i,T), res); - in appy thy ptp E' (l@[R,D]) b a v end - | ay => ay) - - | appy (thy as (th,sr)) ptp E l - (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*) - ((*writeln("### appy While $ c $ e $ a, upd_env= "^ - (subst2str (upd_env E (a,v))));*) - if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c) - then appy thy ptp E (l@[L,R]) e (SOME a) v - else Skip (v, E)) - - | appy (thy as (th,sr)) ptp E l - (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*) - ((*writeln("### appy While $ c $ e, upd_env= "^ - (subst2str (upd_env_opt E (a,v))));*) - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) - then appy thy ptp E (l@[R]) e a v - else Skip (v, E)) - - | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v = - ((*writeln("### appy If: t= "^(term2str t)); - writeln("### appy If: c= "^(term2str(subst_atomic(upd_env_opt E(a,v))c))); - writeln("### appy If: thy= "^(fst thy));*) - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) - then ((*writeln("### appy If: true");*)appy thy ptp E (l@[L,R]) e1 a v) - else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v)) -(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e $ a), _, v) = - (thy, ptp, E, (l@[R]), e, a, v); - *) - | appy thy ptp E (*env*) l - (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v = - ((*writeln("### appy Repeat a: ");*) - appy thy ptp E (*env*) (l@[L,R]) e (SOME a) v) -(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e), _, v) = - (thy, ptp, E, (l@[R]), e, a, v); - *) - | appy thy ptp E (*env*) l - (Const ("Script.Repeat"(*2*),_) $ e) a v = - ((*writeln("3### appy Repeat: a= "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) a));*) - appy thy ptp E (*env*) (l@[R]) e a v) -(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e $ a), _, v)= - (thy, ptp, E, (l@[R]), e2, a, v); - *) - | appy thy ptp E l - (t as Const ("Script.Try",_) $ e $ a) _ v = - (case appy thy ptp E (l@[L,R]) e (SOME a) v of - Napp E => ((*writeln("### appy Try "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - Skip (v, E)) - | ay => ay) -(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)= - (thy, ptp, E, (l@[R]), e2, a, v); - val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)= - (thy, ptp, E, (l@[L,R]), e1, a, v); - *) - | appy thy ptp E l - (t as Const ("Script.Try",_) $ e) a v = - (case appy thy ptp E (l@[R]) e a v of - Napp E => ((*writeln("### appy Try "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - Skip (v, E)) - | ay => ay) - - - | appy thy ptp E l - (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v = - (case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of - Appy lme => Appy lme - | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (SOME a) v) - - | appy thy ptp E l - (Const ("Script.Or"(*2*),_) $e1 $ e2) a v = - (case appy thy ptp E (l@[L,R]) e1 a v of - Appy lme => Appy lme - | _ => appy thy ptp E (l@[R]) e2 a v) - -(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)= - (thy, ptp, E,(up@[R]),e2, a, v); - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)= - (thy, ptp, E,(up@[R,D]),body, a, v); - *) - | appy thy ptp E l - (Const ("Script.Seq"(*1*),_) $ e1 $ e2 $ a) _ v = - ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^ - (subst2str (upd_env E (a,v))));*) - case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of - Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (SOME a) v - | ay => ay) - -(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= - (thy, ptp, E,(up@[R]),e2, a, v); - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= - (thy, ptp, E,(l@[R]), e2, a, v); - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)= - (thy, ptp, E,(up@[R,D]),body, a, v); - *) - | appy thy ptp E l - (Const ("Script.Seq",_) $ e1 $ e2) a v = - (case appy thy ptp E (l@[L,R]) e1 a v of - Skip (v,E) => appy thy ptp E (l@[R]) e2 a v - | ay => ay) - - (*.a leaf has been found*) - | appy (thy as (th,sr)) (pt, p) E l t a v = -(* val (thy as (th,sr),(pt, p),E, l, t, a, v) = - (thy, ptp, E, up@[R,D], body, a, v); - val (thy as (th,sr),(pt, p),E, l, t, a, v) = - (thy, ptp, E, l@[L,R], e, a, v); - val (thy as (th,sr),(pt, p),E, l, t, a, v) = - (thy, ptp, E,(l@[R]), e, a, v); - *) - (case handle_leaf "next " th sr E a v t of -(* val (a', Expr s) = handle_leaf "next " th sr E a v t; - *) - (a', Expr s) => Skip (s, E) -(* val (a', STac stac) = handle_leaf "next " th sr E a v t; - *) - | (a', STac stac) => - let - (*val _= writeln("### appy t, vor stac2tac_ is="); - val _= writeln(istate2str (ScrState (E,l,a',v,Sundef,false)));*) - val (m,m') = stac2tac_ pt (assoc_thy th) stac - in case m of - Subproblem _ => Appy (m', (E,l,a',tac_2res m',Sundef,false)) - | _ => (case applicable_in p pt m of -(* val Appl m' = applicable_in p pt m; - *) - Appl m' => - ((*writeln("### appy: Appy");*) - Appy (m', (E,l,a',tac_2res m',Sundef,false))) - | _ => ((*writeln("### appy: Napp");*)Napp E)) - end); - - -(* val (scr as Script sc, l, t as Const ("Let",_) $ _) = - (Script sc, up, go up sc); - nxt_up thy ptp (Script sc) E l ay t a v; - - val (thy,ptp,scr as (Script sc),E,l, ay, t as Const ("Let",_) $ _, a, v)= - (thy,ptp,Script sc, E,up,ay, go up sc, a, v); - nxt_up thy ptp scr E l ay t a v; - *) -fun nxt_up thy ptp (scr as (Script sc)) E l ay - (t as Const ("Let",_) $ _) a v = (*comes from let=...*) - ((*writeln("### nxt_up1 Let$e: is="); - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) - if ay = Napp_ - then nstep_up thy ptp scr E (drop_last l) Napp_ a v - else (*Skip_*) - let val up = drop_last l; - val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc; - val i = mk_Free (i, T); - val E = upd_env E (i, v); - (*val _= writeln("### nxt_up2 Let$e: is="); - val _= writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) - in case appy thy ptp (E) (up@[R,D]) body a v of - Appy lre => Appy lre - | Napp E => nstep_up thy ptp scr E up Napp_ a v - | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end) - - | nxt_up thy ptp scr E l ay - (t as Abs (_,_,_)) a v = - ((*writeln("### nxt_up Abs: "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - nstep_up thy ptp scr E (*enr*) l ay a v) - - | nxt_up thy ptp scr E l ay - (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v = - ((*writeln("### nxt_up Let$e$Abs: is="); - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*) - (*writeln("### nxt_up Let e Abs: "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - nstep_up thy ptp scr (*upd_env*) E (*a,v)*) - (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v) - - (*no appy_: never causes Napp -> Helpless*) - | nxt_up (thy as (th,sr)) ptp scr E l _ - (Const ("Script.While"(*1*),_) $ c $ e $ _) a v = - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) - then case appy thy ptp E (l@[L,R]) e a v of - Appy lr => Appy lr - | Napp E => nstep_up thy ptp scr E l Skip_ a v - | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v - else nstep_up thy ptp scr E l Skip_ a v - - (*no appy_: never causes Napp - Helpless*) - | nxt_up (thy as (th,sr)) ptp scr E l _ - (Const ("Script.While"(*2*),_) $ c $ e) a v = - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c) - then case appy thy ptp E (l@[R]) e a v of - Appy lr => Appy lr - | Napp E => nstep_up thy ptp scr E l Skip_ a v - | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v - else nstep_up thy ptp scr E l Skip_ a v - -(* val (scr, l) = (Script sc, up); - *) - | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v = - nstep_up thy ptp scr E l ay a v - - | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*) - (Const ("Script.Repeat"(*1*),T) $ e $ _) a v = - (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of - Appy lr => Appy lr - | Napp E => ((*writeln("### nxt_up Repeat a: ");*) - nstep_up thy ptp scr E l Skip_ a v) - | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^ - (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*) - nstep_up thy ptp scr E l Skip_ a v)) - - | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*) - (Const ("Script.Repeat"(*2*),T) $ e) a v = - (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of - Appy lr => Appy lr - | Napp E => ((*writeln("### nxt_up Repeat a: ");*) - nstep_up thy ptp scr E l Skip_ a v) - | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^ - (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*) - nstep_up thy ptp scr E l Skip_ a v)) -(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e $ _), a, v) = - (thy, ptp, (Script sc), - E, up, ay,(go up sc), a, v); - *) - | nxt_up thy ptp scr E l _ (*makes Napp to Skip*) - (t as Const ("Script.Try",_) $ e $ _) a v = - ((*writeln("### nxt_up Try "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - nstep_up thy ptp scr E l Skip_ a v ) -(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e), a, v) = - (thy, ptp, (Script sc), - E, up, ay,(go up sc), a, v); - *) - | nxt_up thy ptp scr E l _ (*makes Napp to Skip*) - (t as Const ("Script.Try"(*2*),_) $ e) a v = - ((*writeln("### nxt_up Try "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*) - nstep_up thy ptp scr E l Skip_ a v) - - - | nxt_up thy ptp scr E l ay - (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v - - | nxt_up thy ptp scr E l ay - (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v - - | nxt_up thy ptp scr E l ay - (Const ("Script.Or",_) $ _ ) a v = - nstep_up thy ptp scr E (drop_last l) ay a v -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ _ $ _), a, v) = - (thy, ptp, (Script sc), - E, up, ay,(go up sc), a, v); - *) - | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*) - (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v = - nstep_up thy ptp scr E l ay a v -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ e2), a, v) = - (thy, ptp, (Script sc), - E, up, ay,(go up sc), a, v); - *) - | nxt_up thy ptp scr E l ay (*comes from e2*) - (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v = - nstep_up thy ptp scr E l ay a v -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _), a, v) = - (thy, ptp, (Script sc), - E, up, ay,(go up sc), a, v); - *) - | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*) - (Const ("Script.Seq",_) $ _) a v = - if ay = Napp_ - then nstep_up thy ptp scr E (drop_last l) Napp_ a v - else (*Skip_*) - let val up = drop_last l; - val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc; - in case appy thy ptp E (up@[R]) e2 a v of - Appy lr => Appy lr - | Napp E => nstep_up thy ptp scr E up Napp_ a v - | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end - - | nxt_up (thy,_) ptp scr E l ay t a v = - raise error ("nxt_up not impl for "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t)) - -(* val (thy, ptp, (Script sc), E, l, ay, a, v)= - (thy, ptp, scr, E, l, Skip_, a, v); - val (thy, ptp, (Script sc), E, l, ay, a, v)= - (thy, ptp, sc, E, l, Skip_, a, v); - *) -and nstep_up thy ptp (Script sc) E l ay a v = - ((*writeln("### nstep_up from: "^(loc_2str l)); - writeln("### nstep_up from: "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go l sc)));*) - if 1 < length l - then - let - val up = drop_last l; - in ((*writeln("### nstep_up to: "^ - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go up sc)));*) - nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end - else (*interpreted to end*) - if ay = Skip_ then Skip (v, E) else Napp E -); - -(* decide for the next applicable stac in the script; - returns (stactic, value) - the value in case the script is finished - 12.8.02: ~~~~~ and no assumptions ??? FIXME ??? - 20.8.02: must return p in case of finished, because the next script - consulted need not be the calling script: - in case of detail ie. _inserted_ PrfObjs, the next stac - has to searched in a script with PblObj.status<>Complete ! - (.. not true for other details ..PrfObj ?????????????????? - 20.8.02: do NOT return safe (is only changed in locate !!!) -*) -(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) = - (thy', (pt,p), sc, RrlsState (ii t)); - val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) = - (thy', (pt',p'), sc, is'); - *) -fun next_tac (thy,_) (pt,p) (Rfuns {next_rule,...}) (RrlsState(f,f',rss,_))= - if f = f' then (End_Detail' (f',[])(*8.6.03*), Uistate, - (f', Sundef(*FIXME is no value of next_tac! vor 8.6.03*))) - (*finished*) - else (case next_rule rss f of - NONE => (Empty_Tac_, Uistate, (e_term, Sundef)) (*helpless*) -(* val SOME (Thm (id,thm)) = next_rule rss f; - *) - | SOME (Thm (id,thm))(*8.6.03: muss auch f' liefern ?!!*) => - (Rewrite' (thy, "e_rew_ord", e_rls,(*!?!8.6.03*) false, - (id, string_of_thmI thm), f,(e_term,[(*!?!8.6.03*)])), - Uistate, (e_term, Sundef))) (*next stac*) - -(* val(thy, ptp as (pt,(p,_)), sc as Script (h $ body),ScrState (E,l,a,v,s,b))= - ((thy',srls), (pt,pos), sc, is); - *) - | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body)) - (ScrState (E,l,a,v,s,b)) = - ((*writeln("### next_tac-----------------: E= "); - writeln( istate2str (ScrState (E,l,a,v,s,b)));*) - case if l=[] then appy thy ptp E [R] body NONE v - else nstep_up thy ptp sc E l Skip_ a v of - Skip (v,_) => (*finished*) - (case par_pbl_det pt p of - (true, p', _) => - let val (_,pblID,_) = get_obj g_spec pt p'; - in (Check_Postcond' (pblID, (v, [(*8.6.03 NO asms???*)])), - e_istate, (v,s)) end - | (_,p',rls') => (End_Detail' (e_term,[])(*8.6.03*), e_istate, (v,s))) - | Napp _ => (Empty_Tac_, e_istate, (e_term, Sundef)) (*helpless*) - | Appy (m', scrst as (_,_,_,v,_,_)) => (m', ScrState scrst, - (v, Sundef))) (*next stac*) - - | next_tac _ _ _ is = raise error ("next_tac: not impl for "^ - (istate2str is)); - - - - -(*.create the initial interpreter state from the items of the guard.*) -(* val (thy, itms, metID) = (thy, itms, mI); - *) -fun init_scrstate thy itms metID = - let val actuals = itms2args thy metID itms; - val scr as Script sc = (#scr o get_met) metID; - val formals = formal_args sc - (*expects same sequence of (actual) args in itms - and (formal) args in met*) - fun relate_args env [] [] = env - | relate_args env _ [] = - raise error ("ERROR in creating the environment for '" - ^id_of_scr sc^"' from \nthe items of the guard of " - ^metID2str metID^",\n\ - \formal arg(s), from the script,\ - \ miss actual arg(s), from the guards env:\n" - ^(string_of_int o length) formals - ^" formals: "^terms2str formals^"\n" - ^(string_of_int o length) actuals - ^" actuals: "^terms2str actuals) - | relate_args env [] actual_finds = env (*may drop Find!*) - | relate_args env (a::aa) (f::ff) = - if type_of a = type_of f - then relate_args (env @ [(a, f)]) aa ff else - raise error ("ERROR in creating the environment for '" - ^id_of_scr sc^"' from \nthe items of the guard of " - ^metID2str metID^",\n\ - \different types of formal arg, from the script,\ - \ and actual arg, from the guards env:'\n\ - \formal: '"^term2str a^"::"^(type2str o type_of) a^"'\n\ - \actual: '"^term2str f^"::"^(type2str o type_of) f^"'\n\ - \in\n\ - \formals: "^terms2str formals^"\n\ - \actuals: "^terms2str actuals) - val env = relate_args [] formals actuals; - in (ScrState (env,[],NONE,e_term,Safe,true), scr):istate * scr end; - -(*.decide, where to get script/istate from: - (*1*) from PblObj.env: at begin of script if no init_form - (*2*) from PblObj/PrfObj: if stac is in the middle of the script - (*3*) from rls/PrfObj: in case of detail a ruleset.*) -(* val (thy', (p,p_), pt) = (thy', (p,p_), pt); - *) -fun from_pblobj_or_detail' thy' (p,p_) pt = - if member op = [Pbl,Met] p_ - then case get_obj g_env pt p of - NONE => raise error "from_pblobj_or_detail': no istate" - | SOME is => - let val metID = get_obj g_metID pt p - val {srls,...} = get_met metID - in (srls, is, (#scr o get_met) metID) end - else - let val (pbl,p',rls') = par_pbl_det pt p - in if pbl - then (*2*) - let val thy = assoc_thy thy' - val PblObj{meth=itms,...} = get_obj I pt p' - val metID = get_obj g_metID pt p' - val {srls,...} = get_met metID - in (*if last_elem p = 0 (*nothing written to pt yet*) - then let val (is, sc) = init_scrstate thy itms metID - in (srls, is, sc) end - else*) (srls, get_istate pt (p,p_), (#scr o get_met) metID) - end - else (*3*) - (e_rls, (*FIXME: get from pbl or met !!! - unused for Rrls in locate_gen, next_tac*) - get_istate pt (p,p_), - case rls' of - Rls {scr=scr,...} => scr - | Seq {scr=scr,...} => scr - | Rrls {scr=rfuns,...} => rfuns) - end; - -(*.get script and istate from PblObj, see (*1*) above.*) -fun from_pblobj' thy' (p,p_) pt = - let val p' = par_pblobj pt p - val thy = assoc_thy thy' - val PblObj{meth=itms,...} = get_obj I pt p' - val metID = get_obj g_metID pt p' - val {srls,scr,...} = get_met metID - in if last_elem p = 0 (*nothing written to pt yet*) - then let val (is, scr) = init_scrstate thy itms metID - in (srls, is, scr) end - else (srls, get_istate pt (p,p_), scr) - end; - -(*.get the stactics and problems of a script as tacs - instantiated with the current environment; - l is the location which generated the given formula.*) -(*WN.12.5.03: quick-and-dirty repair for listexpressions*) -fun is_spec_pos Pbl = true - | is_spec_pos Met = true - | is_spec_pos _ = false; - -(*. fetch _all_ tactics from script .*) -fun sel_rules _ (([],Res):pos') = - raise PTREE "no tactics applicable at the end of a calculation" -| sel_rules pt (p,p_) = - if is_spec_pos p_ - then [get_obj g_tac pt p] - else - let val pp = par_pblobj pt p; - val thy' = (get_obj g_domID pt pp):theory'; - val thy = assoc_thy thy'; - val metID = get_obj g_metID pt pp; - val metID' =if metID =e_metID then(thd3 o snd3)(get_obj g_origin pt pp) - else metID - val {scr=Script sc,srls,...} = get_met metID' - val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_); - in map ((stac2tac pt thy) o rep_stacexpr o #2 o - (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) end; -(* -> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test"); -> val env = [((term_of o the o (parse Isac.thy)) "bdv", - (term_of o the o (parse Isac.thy)) "x")]; -> map ((stac2tac pt thy) o #2 o(subst_stacexpr env NONE e_term)) (stacpbls sc); -*) - - -(*. fetch tactics from script and filter _applicable_ tactics; - in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*) -fun sel_appl_atomic_tacs _ (([],Res):pos') = - raise PTREE "no tactics applicable at the end of a calculation" - | sel_appl_atomic_tacs pt (p,p_) = - if is_spec_pos p_ - then [get_obj g_tac pt p] - else - let val pp = par_pblobj pt p - val thy' = (get_obj g_domID pt pp):theory' - val thy = assoc_thy thy' - val metID = get_obj g_metID pt pp - val metID' =if metID = e_metID - then (thd3 o snd3) (get_obj g_origin pt pp) - else metID - val {scr=Script sc,srls,erls,rew_ord'=ro,...} = get_met metID' - val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_) - val alltacs = (*we expect at least 1 stac in a script*) - map ((stac2tac pt thy) o rep_stacexpr o #2 o - (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) - val f = case p_ of - Frm => get_obj g_form pt p - | Res => (fst o (get_obj g_result pt)) p - (*WN071231 ? replace atomic_appl_tacs with applicable_in (ineff!) ?*) - in (distinct o flat o - (map (atomic_appl_tacs thy ro erls f))) alltacs end; - - -(* -end -open Interpreter; -*) - -(* use"ME/script.sml"; - use"script.sml"; - *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ME/solve.sml --- a/src/Tools/isac/ME/solve.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,579 +0,0 @@ -(* solve an example by interpreting a method's script - (c) Walther Neuper 1999 - -use"ME/solve.sml"; -use"solve.sml"; -*) - -fun safe (ScrState (_,_,_,_,s,_)) = s - | safe (RrlsState _) = Safe; - -type mstID = string; -type tac'_ = mstID * tac; (*DG <-> ME*) -val e_tac'_ = ("Empty_Tac", Empty_Tac):tac'_; - -fun mk_tac'_ m = case m of - Init_Proof (ppc, spec) => ("Init_Proof", Init_Proof (ppc, spec )) -| Model_Problem => ("Model_Problem", Model_Problem) -| Refine_Tacitly pblID => ("Refine_Tacitly", Refine_Tacitly pblID) -| Refine_Problem pblID => ("Refine_Problem", Refine_Problem pblID) -| Add_Given cterm' => ("Add_Given", Add_Given cterm') -| Del_Given cterm' => ("Del_Given", Del_Given cterm') -| Add_Find cterm' => ("Add_Find", Add_Find cterm') -| Del_Find cterm' => ("Del_Find", Del_Find cterm') -| Add_Relation cterm' => ("Add_Relation", Add_Relation cterm') -| Del_Relation cterm' => ("Del_Relation", Del_Relation cterm') - -| Specify_Theory domID => ("Specify_Theory", Specify_Theory domID) -| Specify_Problem pblID => ("Specify_Problem", Specify_Problem pblID) -| Specify_Method metID => ("Specify_Method", Specify_Method metID) -| Apply_Method metID => ("Apply_Method", Apply_Method metID) -| Check_Postcond pblID => ("Check_Postcond", Check_Postcond pblID) -| Free_Solve => ("Free_Solve",Free_Solve) - -| Rewrite_Inst (subs, thm') => ("Rewrite_Inst", Rewrite_Inst (subs, thm')) -| Rewrite thm' => ("Rewrite", Rewrite thm') -| Rewrite_Asm thm' => ("Rewrite_Asm", Rewrite_Asm thm') -| Rewrite_Set_Inst (subs, rls') - => ("Rewrite_Set_Inst", Rewrite_Set_Inst (subs, rls')) -| Rewrite_Set rls' => ("Rewrite_Set", Rewrite_Set rls') -| End_Ruleset => ("End_Ruleset", End_Ruleset) - -| End_Detail => ("End_Detail", End_Detail) -| Detail_Set rls' => ("Detail_Set", Detail_Set rls') -| Detail_Set_Inst (s, rls') => ("Detail_Set_Inst", Detail_Set_Inst (s, rls')) - -| Calculate op_ => ("Calculate", Calculate op_) -| Substitute sube => ("Substitute", Substitute sube) -| Apply_Assumption cts' => ("Apply_Assumption", Apply_Assumption cts') - -| Take cterm' => ("Take", Take cterm') -| Take_Inst cterm' => ("Take_Inst", Take_Inst cterm') -| Group (con, ints) => ("Group", Group (con, ints)) -| Subproblem (domID, pblID) => ("Subproblem", Subproblem (domID, pblID)) -(* -| Subproblem_Full(spec,cts')=> ("Subproblem_Full", Subproblem_Full(spec,cts')) -*) -| End_Subproblem => ("End_Subproblem",End_Subproblem) -| CAScmd cterm' => ("CAScmd", CAScmd cterm') - -| Split_And => ("Split_And", Split_And) -| Conclude_And => ("Conclude_And", Conclude_And) -| Split_Or => ("Split_Or", Split_Or) -| Conclude_Or => ("Conclude_Or", Conclude_Or) -| Begin_Trans => ("Begin_Trans", Begin_Trans) -| End_Trans => ("End_Trans", End_Trans) -| Begin_Sequ => ("Begin_Sequ", Begin_Sequ) -| End_Sequ => ("End_Sequ", Begin_Sequ) -| Split_Intersect => ("Split_Intersect", Split_Intersect) -| End_Intersect => ("End_Intersect", End_Intersect) -| Check_elementwise cterm' => ("Check_elementwise", Check_elementwise cterm') -| Or_to_List => ("Or_to_List", Or_to_List) -| Collect_Trues => ("Collect_Results", Collect_Trues) - -| Empty_Tac => ("Empty_Tac",Empty_Tac) -| Tac string => ("Tac",Tac string) -| User => ("User",User) -| End_Proof' => ("End_Proof'",End_Proof'); - -(*Detail*) -val empty_tac'_ = (mk_tac'_ Empty_Tac):tac'_; - -fun mk_tac ((_,m):tac'_) = m; -fun mk_mstID ((mI,_):tac'_) = mI; - -fun tac'_2str ((ID,ms):tac'_) = ID ^ (tac2str ms); -(* TODO: tac2str, tac'_2str NOT tested *) - - - -type squ = ptree; (* TODO: safe etc. *) - -(*13.9.02-------------- -type ctr = (loc * pos) list; -val ops = [("PLUS","op +"),("minus","op -"),("TIMES","op *"), - ("cancel","cancel"),("pow","pow"),("sqrt","sqrt")]; -fun op_intern op_ = - case assoc (ops,op_) of - SOME op' => op' | NONE => raise error ("op_intern: no op= "^op_); ------------------------*) - - - -(* use"ME/solve.sml"; - use"solve.sml"; - -val ttt = (term_of o the o (parse thy))"Substitute [(bdv,x)] g"; -val ttt = (term_of o the o (parse thy))"Rewrite thmid True g"; - - Const ("Script.Rewrite'_Inst",_) $ sub $ Free (thm',_) $ Const (pa,_) $ f' - *) - - - -val specsteps = ["Init_Proof","Refine_Tacitly","Refine_Problem", - "Model_Problem",(*"Match_Problem",*) - "Add_Given","Del_Given","Add_Find","Del_Find", - "Add_Relation","Del_Relation", - "Specify_Theory","Specify_Problem","Specify_Method"]; - -"-----------------------------------------------------------------------"; - - -fun step2taci ((tac_, _, pt, p, _):step) = (*FIXXME.040312: redesign step*) - (tac_2tac tac_, tac_, (p, get_istate pt p)):taci; - - -(*FIXME.WN050821 compare solve ... nxt_solv*) -(* val ("Apply_Method",Apply_Method' (mI,_))=(mI,m); - val (("Apply_Method",Apply_Method' (mI,_,_)),pt, pos as (p,_))=(m,pt, pos); - *) -fun solve ("Apply_Method", m as Apply_Method' (mI, _, _)) - (pt:ptree, (pos as (p,_))) = - let val {srls,...} = get_met mI; - val PblObj{meth=itms,...} = get_obj I pt p; - val thy' = get_obj g_domID pt p; - val thy = assoc_thy thy'; - val (is as ScrState (env,_,_,_,_,_), sc) = init_scrstate thy itms mI; - val ini = init_form thy sc env; - val p = lev_dn p; - in - case ini of - SOME t => (* val SOME t = ini; - *) - let val (pos,c,_,pt) = - generate1 thy (Apply_Method' (mI, SOME t, is)) - is (lev_on p, Frm)(*implicit Take*) pt; - in ("ok",([(Apply_Method mI, Apply_Method' (mI, SOME t, is), - ((lev_on p, Frm), is))], c, (pt,pos)):calcstate') - end - | NONE => (*execute the first tac in the Script, compare solve m*) - let val (m', is', _) = next_tac (thy', srls) (pt, (p, Res)) sc is; - val d = e_rls (*FIXME: get simplifier from domID*); - in - case locate_gen (thy',srls) m' (pt,(p, Res))(sc,d) is' of - Steps (is'', ss as (m'',f',pt',p',c')::_) => -(* val Steps (is'', ss as (m'',f',pt',p',c')::_) = - locate_gen (thy',srls) m' (pt,(p,Res)) (sc,d) is'; - *) - ("ok", (map step2taci ss, c', (pt',p'))) - | NotLocatable => - let val (p,ps,f,pt) = - generate_hard (assoc_thy "Isac.thy") m (p,Frm) pt; - in ("not-found-in-script", - ([(tac_2tac m, m, (pos, is))], ps, (pt,p))) end - (*just-before------------------------------------------------------ - ("ok",([(Apply_Method mI,Apply_Method'(mI,NONE,e_istate), - (pos, is))], - [], (update_env pt (fst pos) (SOME is),pos))) - -----------------------------------------------------------------*) - end - end - - | solve ("Free_Solve", Free_Solve') (pt,po as (p,_)) = - let (*val _=writeln"###solve Free_Solve";*) - val p' = lev_dn_ (p,Res); - val pt = update_metID pt (par_pblobj pt p) e_metID; - in ("ok", ((*(p',Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Unsafe,*) - [(Empty_Tac, Empty_Tac_, (po, Uistate))], [], (pt,p'))) end - -(* val (("Check_Postcond",Check_Postcond' (pI,_)), (pt,(pos as (p,p_)))) = - ( m, (pt, pos)); - *) - | solve ("Check_Postcond",Check_Postcond' (pI,_)) (pt,(pos as (p,p_))) = - let (*val _=writeln"###solve Check_Postcond";*) - val pp = par_pblobj pt p - val asm = (case get_obj g_tac pt p of - Check_elementwise _ => (*collects and instantiates asms*) - (snd o (get_obj g_result pt)) p - | _ => ((map fst) o (get_assumptions_ pt)) (p,p_)) - handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*) - val metID = get_obj g_metID pt pp; - val {srls=srls,scr=sc,...} = get_met metID; - val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_); - (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_))); - val _= writeln("### solve Check_postc, is= "^(istate2str is));*) - val thy' = get_obj g_domID pt pp; - val thy = assoc_thy thy'; - val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is; - (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*) - - in if pp = [] then - let val is = ScrState (E,l,a,scval,scsaf,b) - val tac_ = Check_Postcond'(pI,(scval, map term2str asm)) - val (pos,ps,f,pt) = generate1 thy tac_ is (pp,Res) pt; - in ("ok", ((*(([],Res),is,End_Proof''), f, End_Proof', scsaf,*) - [(Check_Postcond pI, tac_, ((pp,Res),is))], ps,(pt,pos))) end - else - let - (*resume script of parpbl, transfer value of subpbl-script*) - val ppp = par_pblobj pt (lev_up p); - val thy' = get_obj g_domID pt ppp; - val thy = assoc_thy thy'; - val metID = get_obj g_metID pt ppp; - val sc = (#scr o get_met) metID; - val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm); - (*val _=writeln("### solve Check_postc, parpbl pos= "^(pos'2str(pp,Frm))); - val _=writeln("### solve Check_postc, is(pt)= "^(istate2str is)); - val _=writeln("### solve Check_postc, is'= "^ - (istate2str (E,l,a,scval,scsaf,b)));*) - val ((p,p_),ps,f,pt) = - generate1 thy (Check_Postcond' (pI, (scval, map term2str asm))) - (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt; - (*val _=writeln("### solve Check_postc, is(pt')= "^ - (istate2str (get_istate pt ([3],Res)))); - val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) sc - (ScrState (E,l,a,scval,scsaf,b));*) - in ("ok",(*((pp,Res),is',nx), f, tac_2tac nx, scsaf,*) - ([(Check_Postcond pI, Check_Postcond'(pI,(scval, map term2str asm)), - ((pp,Res), ScrState (E,l,a,scval,scsaf,b)))],ps,(pt,(p,p_)))) - end - end -(* val (msg, cs') = - ("ok",([(Check_Postcond pI,Check_Postcond'(pI, (scval, map term2str asm))), - ((pp,Res),(ScrState (E,l,a,scval,scsaf,b)))], (pt,(p,p_)))); - val (_,(pt',p')) = cs'; - (writeln o istate2str) (get_istate pt' p'); - (term2str o fst) (get_obj g_result pt' (fst p')); - *) - -(* writeln(istate2str(get_istate pt (p,p_))); - *) - | solve (_,End_Proof'') (pt, (p,p_)) = - ("end-proof", - ((*(([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe,*) - [(Empty_Tac,Empty_Tac_,(([],Res),Uistate))],[],(pt,(p,p_)))) - -(*-----------vvvvvvvvvvv could be done by generate1 ?!?*) - | solve (_,End_Detail' t) (pt,(p,p_)) = - let val pr as (p',_) = (lev_up p, Res) - val pp = par_pblobj pt p - val r = (fst o (get_obj g_result pt)) p' - (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*) - val thy' = get_obj g_domID pt pp - val (srls, is, sc) = from_pblobj' thy' pr pt - val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is - in ("ok", ((*((pp,Frm(*???*)),is,tac_), - Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)), - tac_2tac tac_, Sundef,*) - [(End_Detail, End_Detail' t , - ((p,p_), get_istate pt (p,p_)))], [], (pt,pr))) end - - | solve (mI,m) (pt, po as (p,p_)) = -(* val ((mI,m), (pt, po as (p,p_))) = (m, (pt, pos)); - *) - if e_metID = get_obj g_metID pt (par_pblobj pt p)(*29.8.02: - could be detail, too !!*) - then let val ((p,p_),ps,f,pt) = - generate1 (assoc_thy (get_obj g_domID pt (par_pblobj pt p))) - m e_istate (p,p_) pt; - in ("no-method-specified", (*Free_Solve*) - ((*((p,p_),Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*) - [(Empty_Tac,Empty_Tac_, ((p,p_),Uistate))], ps, (pt,(p,p_)))) end - else - let - val thy' = get_obj g_domID pt (par_pblobj pt p); - val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt; -(*val _= writeln("### solve, before locate_gen p="^(pos'2str(p,p_)));*) - val d = e_rls; (*FIXME: canon.simplifier for domain is missing - 8.01: generate from domID?*) - in case locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is of - Steps (is', ss as (m',f',pt',p',c')::_) => -(* val Steps (is', ss as (m',f',pt',p',c')::_) = - locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is; - *) - let (*val _= writeln("### solve, after locate_gen: is= ") - val _= writeln(istate2str is')*) - (*val nxt_ = - case p' of (*change from solve to model subpbl*) - (_,Pbl) => nxt_model_pbl m' (pt',p') - | _ => fst3 (next_tac (thy',srls) (pt',p') sc is');*) - (*27.8.02:next_tac may change to other branches in pt FIXXXXME*) - in ("ok", ((*(p',is',nxt_), f', tac_2tac nxt_, safe is',*) - map step2taci ss, c', (pt',p'))) end - | NotLocatable => - let val (p,ps,f,pt) = - generate_hard (assoc_thy "Isac.thy") m (p,p_) pt; - in ("not-found-in-script", - ((*(p,Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*) - [(tac_2tac m, m, (po,is))], ps, (pt,p))) end - end; - - -(*FIXME.WN050821 compare solve ... nxt_solv*) -(* nxt_solv (Apply_Method' vvv FIXME: get args in applicable_in *) -fun nxt_solv (Apply_Method' (mI,_,_)) _ (pt:ptree, pos as (p,_)) = -(* val ((Apply_Method' (mI,_,_)), _, (pt:ptree, pos as (p,_))) = - ((Apply_Method' (mI, NONE, e_istate)), e_istate, ptp); - *) - let val {srls,ppc,...} = get_met mI; - val PblObj{meth=itms,origin=(oris,_,_),probl,...} = get_obj I pt p; - val itms = if itms <> [] then itms - else complete_metitms oris probl [] ppc - val thy' = get_obj g_domID pt p; - val thy = assoc_thy thy'; - val (is as ScrState (env,_,_,_,_,_), scr) = init_scrstate thy itms mI; - val ini = init_form thy scr env; - in - case ini of - SOME t => (* val SOME t = ini; - *) - let val pos = ((lev_on o lev_dn) p, Frm) - val tac_ = Apply_Method' (mI, SOME t, is); - val (pos,c,_,pt) = (*implicit Take*) - generate1 thy tac_ is pos pt - (*val _= ("### nxt_solv Apply_Method, pos= "^pos'2str (lev_on p,Frm));*) - in ([(Apply_Method mI, tac_, (pos, is))], c, (pt, pos)):calcstate' end - | NONE => - let val pt = update_env pt (fst pos) (SOME is) - val (tacis, c, ptp) = nxt_solve_ (pt, pos) - in (tacis @ - [(Apply_Method mI, Apply_Method' (mI, NONE, e_istate), (pos, is))], - c, ptp) end - end -(* val ("Check_Postcond",Check_Postcond' (pI,_)) = (mI,m); - val (Check_Postcond' (pI,_), _, (pt, pos as (p,p_))) = - (tac_, is, ptp); - *) - (*TODO.WN050913 remove unnecessary code below*) - | nxt_solv (Check_Postcond' (pI,_)) _ (pt, pos as (p,p_)) = - let (*val _=writeln"###solve Check_Postcond";*) - val pp = par_pblobj pt p - val asm = (case get_obj g_tac pt p of - Check_elementwise _ => (*collects and instantiates asms*) - (snd o (get_obj g_result pt)) p - | _ => ((map fst) o (get_assumptions_ pt)) (p,p_)) - handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*) - val metID = get_obj g_metID pt pp; - val {srls=srls,scr=sc,...} = get_met metID; - val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_); - (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_))); - val _= writeln("### solve Check_postc, is= "^(istate2str is));*) - val thy' = get_obj g_domID pt pp; - val thy = assoc_thy thy'; - val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is; - (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*) - in if pp = [] then - let val is = ScrState (E,l,a,scval,scsaf,b) - val tac_ = Check_Postcond'(pI,(scval, map term2str asm)) - (*val _= writeln"### nxt_solv2 Apply_Method: stored is ="; - val _= writeln(istate2str is);*) - val ((p,p_),ps,f,pt) = - generate1 thy tac_ is (pp,Res) pt; - in ([(Check_Postcond pI, tac_, ((pp,Res), is))],ps,(pt, (p,p_))) end - else - let - (*resume script of parpbl, transfer value of subpbl-script*) - val ppp = par_pblobj pt (lev_up p); - val thy' = get_obj g_domID pt ppp; - val thy = assoc_thy thy'; - val metID = get_obj g_metID pt ppp; - val {scr,...} = get_met metID; - val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm) - val tac_ = Check_Postcond' (pI, (scval, map term2str asm)) - val is = ScrState (E,l,a,scval,scsaf,b) - (*val _= writeln"### nxt_solv3 Apply_Method: stored is ="; - val _= writeln(istate2str is);*) - val ((p,p_),ps,f,pt) = generate1 thy tac_ is (pp, Res) pt; - (*val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) scr is;WN050913*) - in ([(Check_Postcond pI, tac_, ((pp, Res), is))], ps, (pt, (p,p_))) end - end -(* writeln(istate2str(get_istate pt (p,p_))); - *) - -(*.start interpreter and do one rewrite.*) -(* val (_,Detail_Set'(thy',rls,t)) = (mI,m); val p = (p,p_); - solve ("",Detail_Set'(thy', rls, t)) p pt; - | nxt_solv (Detail_Set'(thy', rls, t)) _ (pt, p) = ********** ----> FE-interface/sml.sml - - | nxt_solv (End_Detail' t) _ (pt, (p,p_)) = ********** - let val pr as (p',_) = (lev_up p, Res) - val pp = par_pblobj pt p - val r = (fst o (get_obj g_result pt)) p' - (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*) - val thy' = get_obj g_domID pt pp - val (srls, is, sc) = from_pblobj' thy' pr pt - val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is - in (pr, ((pp,Frm(*???*)),is,tac_), - Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)), - tac_2tac tac_, Sundef, pt) end -*) - | nxt_solv (End_Proof'') _ ptp = ([], [], ptp) - - | nxt_solv tac_ is (pt, pos as (p,p_)) = -(* val (pt, pos as (p,p_)) = ptp; - *) - let val pos = case pos of - (p, Met) => ((lev_on o lev_dn) p, Frm)(*begin script*) - | (p, Res) => (lev_on p,Res) (*somewhere in script*) - | _ => pos (*somewhere in script*) - (*val _= writeln"### nxt_solv4 Apply_Method: stored is ="; - val _= writeln(istate2str is);*) - val (pos',c,_,pt) = generate1 (assoc_thy "Isac.thy") tac_ is pos pt; - in ([(tac_2tac tac_, tac_, (pos,is))], c, (pt, pos')) end - - - (*(p,p_), (([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe, pt*) - - -(*.find the next tac from the script, nxt_solv will update the ptree.*) -(* val (ptp as (pt,pos as (p,p_))) = ptp'; - val (ptp as (pt, pos as (p,p_))) = ptp''; - val (ptp as (pt, pos as (p,p_))) = ptp; - val (ptp as (pt, pos as (p,p_))) = (pt,ip); - val (ptp as (pt, pos as (p,p_))) = (pt, pos); - *) -and nxt_solve_ (ptp as (pt, pos as (p,p_))) = - if e_metID = get_obj g_metID pt (par_pblobj pt p) - then ([], [], (pt,(p,p_))):calcstate' - else let val thy' = get_obj g_domID pt (par_pblobj pt p); - val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt; - val (tac_,is,(t,_)) = next_tac (thy',srls) (pt,pos) sc is; - (*TODO here ^^^ return finished/helpless/ok !*) - (* val (tac_',is',(t',_)) = next_tac (thy',srls) (pt,pos) sc is; - *) - in case tac_ of - End_Detail' _ => ([(End_Detail, - End_Detail' (t,[(*FIXME.040215*)]), - (pos, is))], [], (pt, pos)) - | _ => nxt_solv tac_ is ptp end; - -(*.says how may steps of a calculation should be done by "fun autocalc".*) -(*TODO.WN0512 redesign togehter with autocalc ?*) -datatype auto = - Step of int (*1 do #int steps; may stop in model/specify: - IS VERY INEFFICIENT IN MODEL/SPECIY*) -| CompleteModel (*2 complete modeling - if model complete, finish specifying + start solving*) -| CompleteCalcHead (*3 complete model/specify in one go + start solving*) -| CompleteToSubpbl (*4 stop at the next begin of a subproblem, - if none, complete the actual (sub)problem*) -| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*) -| CompleteCalc; (*6 complete the calculation as a whole*) -fun autoord (Step _ ) = 1 - | autoord CompleteModel = 2 - | autoord CompleteCalcHead = 3 - | autoord CompleteToSubpbl = 4 - | autoord CompleteSubpbl = 5 - | autoord CompleteCalc = 6; - -(* val (auto, c, (ptp as (_, p))) = (auto, (c@c'), ptp); - *) -fun complete_solve auto c (ptp as (_, p): ptree * pos') = - if p = ([], Res) then ("end-of-calculation", [], ptp) else - case nxt_solve_ ptp of - ((Subproblem _, tac_, (_, is))::_, c', ptp') => -(* val ptp' = ptp'''; - *) - if autoord auto < 5 then ("ok", c@c', ptp) - else let val ptp = all_modspec ptp'; - val (_, c'', ptp) = all_solve auto (c@c') ptp; - in complete_solve auto (c@c'@c'') ptp end - | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) => - if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp') - else complete_solve auto (c@c') ptp' - | ((End_Detail, _, _)::_, c', ptp') => - if autoord auto < 6 then ("ok", c@c', ptp') - else complete_solve auto (c@c') ptp' - | (_, c', ptp') => complete_solve auto (c@c') ptp' -(* val (tacis, c', ptp') = nxt_solve_ ptp; - val (tacis, c', ptp'') = nxt_solve_ ptp'; - val (tacis, c', ptp''') = nxt_solve_ ptp''; - val (tacis, c', ptp'''') = nxt_solve_ ptp'''; - val (tacis, c', ptp''''') = nxt_solve_ ptp''''; - *) -and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') = -(* val (ptp as (pt, (p,_))) = ptp; - val (ptp as (pt, (p,_))) = ptp'; - val (ptp as (pt, (p,_))) = (pt, pos); - *) - let val (_,_,mI) = get_obj g_spec pt p; - val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate)) - e_istate ptp; - in complete_solve auto (c@c') ptp end; -(*@@@ vvv @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) -fun complete_solve auto c (ptp as (_, p as (_,p_)): ptree * pos') = - if p = ([], Res) then ("end-of-calculation", [], ptp) else - if member op = [Pbl,Met] p_ - then let val ptp = all_modspec ptp - val (_, c', ptp) = all_solve auto c ptp - in complete_solve auto (c@c') ptp end - else case nxt_solve_ ptp of - ((Subproblem _, tac_, (_, is))::_, c', ptp') => - if autoord auto < 5 then ("ok", c@c', ptp) - else let val ptp = all_modspec ptp' - val (_, c'', ptp) = all_solve auto (c@c') ptp - in complete_solve auto (c@c'@c'') ptp end - | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) => - if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp') - else complete_solve auto (c@c') ptp' - | ((End_Detail, _, _)::_, c', ptp') => - if autoord auto < 6 then ("ok", c@c', ptp') - else complete_solve auto (c@c') ptp' - | (_, c', ptp') => complete_solve auto (c@c') ptp' -and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') = - let val (_,_,mI) = get_obj g_spec pt p - val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate)) - e_istate ptp - in complete_solve auto (c@c') ptp end; - -(*.aux.fun for detailrls with Rrls, reverse rewriting.*) -(* val (nds, t, ((rule, (t', asm)) :: rts)) = ([], t, rul_terms); - *) -fun rul_terms_2nds nds t [] = nds - | rul_terms_2nds nds t ((rule, res as (t', _)) :: rts) = - (append_atomic [] e_istate t (rule2tac [] rule) res Complete EmptyPtree) :: - (rul_terms_2nds nds t' rts); - - -(*. detail steps done internally by Rewrite_Set* - into ctree by use of a script .*) -(* val (pt, (p,p_)) = (pt, pos); - *) -fun detailrls pt ((p,p_):pos') = - let val t = get_obj g_form pt p - val tac = get_obj g_tac pt p - val rls = (assoc_rls o rls_of) tac - in case rls of -(* val Rrls {scr = Rfuns {init_state,...},...} = rls; - *) - Rrls {scr = Rfuns {init_state,...},...} => - let val (_,_,_,rul_terms) = init_state t - val newnds = rul_terms_2nds [] t rul_terms - val pt''' = ins_chn newnds pt p - in ("detailrls", pt''', (p @ [length newnds], Res):pos') end - | _ => - let val is = init_istate tac t - (*TODO.WN060602 ScrState (["(t_, Problem (Isac,[equation,univar]))"] - is wrong for simpl, but working ?!? *) - val tac_ = Apply_Method' (e_metID(*WN0402: see generate1 !?!*), - SOME t, is) - val pos' = ((lev_on o lev_dn) p, Frm) - val thy = assoc_thy "Isac.thy" - val (_,_,_,pt') = (*implicit Take*)generate1 thy tac_ is pos' pt - val (_,_,(pt'',_)) = complete_solve CompleteSubpbl [] (pt',pos') - val newnds = children (get_nd pt'' p) - val pt''' = ins_chn newnds pt p - (*complete_solve cuts branches after*) - in ("detailrls", pt'''(*, get_formress [] ((lev_on o lev_dn) p)cn*), - (p @ [length newnds], Res):pos') end - end; - - - -(* val(mI,m)=m;val ppp=p;(*!!!*)val(p,p_)=pos;val(_,pt,_)=ppp(*!!!*); - get_form ((mI,m):tac'_) ((p,p_):pos') ppp; - *) -fun get_form ((mI,m):tac'_) ((p,p_):pos') pt = - case applicable_in (p,p_) pt m of - Notappl e => Error' (Error_ e) - | Appl m => - (* val Appl m=applicable_in (p,p_) pt m; - *) - if member op = specsteps mI - then let val (_,_,f,_,_,_) = specify m (p,p_) [] pt - in f end - else let val (*_,_,f,_,_,_*)_ = solve (mI,m) (pt,(p,p_)) - in (*f*) EmptyMout end; - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/Isabelle-isac-conflicts --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/Isabelle-isac-conflicts Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,22 @@ +6.8.02: +(1) special constants are already defined by Isabelle2002, + and thus cannot be parsed from terms; eg. + + Reals thus formula 'subproblem (Reals,...)' not possible + power thus 'Calculate power' not possible in Scripts + +(2) numerals in (terms and) thms are stored differently: + string Isabelle term isac term + 123 Bin.... Free("123",_) + 0 Const("0",_) Free("0",_) + 0 Const("1",_) Free("1",_) + +(3) overwritteln functions + find_first see isac/ROOT.ML + + +Questions for Isabelle team: + +28.02.03 +(4) what is going on in Isa02/Typefix.thy (Markus Wenzen) ? +(5) how avoid "- x" ---parse---> Free ("-x", _) ? \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/ListC.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/ListC.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,204 @@ +(* use_thy_only"../ProgLang/ListC"; + use_thy_only"ProgLang/ListC"; + use_thy"ProgLang/ListC"; + + use_thy_only"ListC"; + W.N. 8.01 + attaches identifiers to definition of listfuns, + for storing them in list_rls + +WN.29.4.03: +*) + +theory ListC imports Complex_Main +uses ("library.sml")("calcelems.sml") +("ProgLang/term.sml")("ProgLang/calculate.sml") +("ProgLang/rewrite.sml") +begin +use "library.sml" (*indent,...*) +use "calcelems.sml" (*str_of_type, Thm,...*) +use "ProgLang/term.sml" (*num_str,...*) +use "ProgLang/calculate.sml" (*???*) +use "ProgLang/rewrite.sml" (*?*** At command "end" (line 205../ListC.thy*) + +text {* 'nat' in List.thy replaced by 'real' *} + +primrec length_' :: "'a list => real" +where + LENGTH_NIL: "length_' [] = 0" (*length: 'a list => nat*) +| LENGTH_CONS: "length_' (x#xs) = 1 + length_' xs" + +primrec del :: "['a list, 'a] => 'a list" +where + del_base: "del [] x = []" +| del_rec: "del (y#ys) x = (if x = y then ys else y#(del ys x))" + +definition + list_diff :: "['a list, 'a list] => 'a list" (* as -- bs *) + ("(_ --/ _)" [66, 66] 65) + where "a -- b == foldl del a b" + +consts nth_' :: "[real, 'a list] => 'a" +axioms + (*** more than one non-variable in pattern in "nth_ 1 [x] = x"--*) + NTH_NIL: "nth_' 1 (x#xs) = x" +(* NTH_CONS: "nth_' n (x#xs) = nth_' (n+ -1) xs" *) + +(*rewriter does not reach base case ...... ; + the condition involves another rule set (erls, eval_binop in Atools):*) + NTH_CONS: "1 < n ==> nth_' n (x#xs) = nth_' (n+ - 1) xs" + +(*primrec from Isabelle/src/HOL/List.thy -- def.twice not allowed*) +(*primrec*) + hd_thm: "hd(x#xs) = x" +(*primrec*) + tl_Nil: "tl([]) = []" + tl_Cons: "tl(x#xs) = xs" +(*primrec*) + null_Nil: "null([]) = True" + null_Cons: "null(x#xs) = False" +(*primrec*) + LAST: "last(x#xs) = (if xs=[] then x else last xs)" +(*primrec*) + butlast_Nil: "butlast [] = []" + butlast_Cons: "butlast(x#xs) = (if xs=[] then [] else x#butlast xs)" +(*primrec*) + mem_Nil: "x mem [] = False" + mem_Cons: "x mem (y#ys) = (if y=x then True else x mem ys)" +(*primrec-------already named--- + "set [] = {}" + "set (x#xs) = insert x (set xs)" + primrec + list_all_Nil "list_all P [] = True" + list_all_Cons "list_all P (x#xs) = (P(x) & list_all P xs)" +----------------*) +(*primrec*) + map_Nil: "map f [] = []" + map_Cons: "map f (x#xs) = f(x)#map f xs" +(*primrec*) + append_Nil: "[] @ys = ys" + append_Cons: "(x#xs)@ys = x#(xs@ys)" +(*primrec*) + rev_Nil: "rev([]) = []" + rev_Cons: "rev(x#xs) = rev(xs) @ [x]" +(*primrec*) + filter_Nil: "filter P [] = []" + filter_Cons: "filter P (x#xs) =(if P x then x#filter P xs else filter P xs)" +(*primrec-------already named--- + foldl_Nil "foldl f a [] = a" + foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs" +----------------*) +(*primrec*) + foldr_Nil: "foldr f [] a = a" + foldr_Cons: "foldr f (x#xs) a = f x (foldr f xs a)" +(*primrec*) + concat_Nil: "concat([]) = []" + concat_Cons: "concat(x#xs) = x @ concat(xs)" +(*primrec-------already named--- + drop_Nil "drop n [] = []" + drop_Cons "drop n (x#xs) = (case n of 0 => x#xs | Suc(m) => drop m xs)" + (* Warning: simpset does not contain this definition but separate theorems + for n=0 / n=Suc k*) +(*primrec*) + take_Nil "take n [] = []" + take_Cons "take n (x#xs) = (case n of 0 => [] | Suc(m) => x # take m xs)" + (* Warning: simpset does not contain this definition but separate theorems + for n=0 / n=Suc k*) +(*primrec*) + nth_Cons "(x#xs)!n = (case n of 0 => x | (Suc k) => xs!k)" + (* Warning: simpset does not contain this definition but separate theorems + for n=0 / n=Suc k*) +(*primrec*) + " [][i:=v] = []" + "(x#xs)[i:=v] = (case i of 0 => v # xs + | Suc j => x # xs[j:=v])" +----------------*) +(*primrec*) + takeWhile_Nil: "takeWhile P [] = []" + takeWhile_Cons: + "takeWhile P (x#xs) = (if P x then x#takeWhile P xs else [])" +(*primrec*) + dropWhile_Nil: "dropWhile P [] = []" + dropWhile_Cons: + "dropWhile P (x#xs) = (if P x then dropWhile P xs else x#xs)" +(*primrec*) + zip_Nil: "zip xs [] = []" + zip_Cons: "zip xs (y#ys) =(case xs of [] => [] | z#zs =>(z,y)#zip zs ys)" + (* Warning: simpset does not contain this definition but separate theorems + for xs=[] / xs=z#zs *) +(*primrec + upt_0 "[i..0(] = []" + upt_Suc "[i..(Suc j)(] = (if i <= j then [i..j(] @ [j] else [])" +*) +(*primrec*) + distinct_Nil: "distinct [] = True" + distinct_Cons: "distinct (x#xs) = (x ~: set xs & distinct xs)" +(*primrec*) + remdups_Nil: "remdups [] = []" + remdups_Cons: "remdups (x#xs) = + (if x : set xs then remdups xs else x # remdups xs)" +(*primrec-------already named--- + replicate_0 "replicate 0 x = []" + replicate_Suc "replicate (Suc n) x = x # replicate n x" +----------------*) + +(** Lexicographic orderings on lists ...!!!**) + +ML{* (*the former ListC.ML*) +(** rule set for evaluating listexpr in scripts **) +val list_rls = + Rls{id="list_rls",preconds = [], rew_ord = ("dummy_ord",dummy_ord), + erls = e_rls, srls = Erls, calc = [], (*asm_thm=[],*) + rules = (*8.01: copied from*) + [Thm ("refl", num_str refl), (*'a<>b -> FALSE' by fun eval_equal*) + Thm ("o_apply", num_str @{thm o_apply}), + + Thm ("NTH_CONS",num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*) + Thm ("NTH_NIL",num_str @{thm NTH_NIL}), + Thm ("append_Cons",num_str @{thm append_Cons}), + Thm ("append_Nil",num_str @{thm append_Nil}), + Thm ("butlast_Cons",num_str @{thm butlast_Cons}), + Thm ("butlast_Nil",num_str @{thm butlast_Nil}), + Thm ("concat_Cons",num_str @{thm concat_Cons}), + Thm ("concat_Nil",num_str @{thm concat_Nil}), + Thm ("del_base",num_str @{thm del_base}), + Thm ("del_rec",num_str @{thm del_rec}), + + Thm ("distinct_Cons",num_str @{thm distinct_Cons}), + Thm ("distinct_Nil",num_str @{thm distinct_Nil}), + Thm ("dropWhile_Cons",num_str @{thm dropWhile_Cons}), + Thm ("dropWhile_Nil",num_str @{thm dropWhile_Nil}), + Thm ("filter_Cons",num_str @{thm filter_Cons}), + Thm ("filter_Nil",num_str @{thm filter_Nil}), + Thm ("foldr_Cons",num_str @{thm foldr_Cons}), + Thm ("foldr_Nil",num_str @{thm foldr_Nil}), + Thm ("hd_thm",num_str @{thm hd_thm}), + Thm ("LAST",num_str @{thm LAST}), + Thm ("LENGTH_CONS",num_str @{thm LENGTH_CONS}), + Thm ("LENGTH_NIL",num_str @{thm LENGTH_NIL}), + Thm ("list_diff_def",num_str @{thm list_diff_def}), + Thm ("map_Cons",num_str @{thm map_Cons}), + Thm ("map_Nil",num_str @{thm map_Cons}), + Thm ("mem_Cons",num_str @{thm mem_Cons}), + Thm ("mem_Nil",num_str @{thm mem_Nil}), + Thm ("null_Cons",num_str @{thm null_Cons}), + Thm ("null_Nil",num_str @{thm null_Nil}), + Thm ("remdups_Cons",num_str @{thm remdups_Cons}), + Thm ("remdups_Nil",num_str @{thm remdups_Nil}), + Thm ("rev_Cons",num_str @{thm rev_Cons}), + Thm ("rev_Nil",num_str @{thm rev_Nil}), + Thm ("take_Nil",num_str @{thm take_Nil}), + Thm ("take_Cons",num_str @{thm take_Cons}), + Thm ("tl_Cons",num_str @{thm tl_Cons}), + Thm ("tl_Nil",num_str @{thm tl_Nil}), + Thm ("zip_Cons",num_str @{thm zip_Cons}), + Thm ("zip_Nil",num_str @{thm zip_Nil}) + ], scr = EmptyScr}:rls; +*} + +ML{* +ruleset' := overwritelthy @{theory} (!ruleset', + [("list_rls",list_rls) + ]); +*} +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/Real2002-theorems.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/Real2002-theorems.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1005 @@ +(*WN060306 from isabelle-users: +put expressions involving plus and minus into a canonical form. Here is a possible set of +rules: + + add_assoc add_commute + diff_def minus_add_distrib + minus_minus minus_zero +===========================================================================*) + +(* + cd ~/Isabelle2002/src/HOL/Real + grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml + WN 9.8.02 + +ML> thy; +val it = + {ProtoPure, CPure, HOL, Set, Typedef, Fun, Product_Type, Lfp, Gfp, Sum_Type, + Relation, Record, Inductive, Transitive_Closure, Wellfounded_Recursion, + NatDef, Nat, NatArith, Divides, Power, SetInterval, Finite_Set, Equiv, + IntDef, Int, Datatype_Universe, Datatype, Numeral, Bin, IntArith, + Wellfounded_Relations, Recdef, IntDiv, IntPower, NatBin, NatSimprocs, + Relation_Power, PreList, List, Map, Hilbert_Choice, Main, Lubs, PNat, PRat, + PReal, RealDef, RealOrd, RealInt, RealBin, RealArith0, RealArith, + RComplete, RealAbs, RealPow, Ring_and_Field, Complex_Numbers, Real} + : theory + +theories with their respective theorems found by +grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml; +theories listed in the the order as found in Real.thy above + +comments + (**)"...theorem..." : first choice for one of the rule-sets + "...theorem..."(*??*): to be investigated + "...theorem... : just for documenting the contents +*) + +Lubs.ML:qed ----------------------------------------------------------------- + "setleI"; "ALL y::?'a:?S::?'a set. y <= (?x::?'a) ==> ?S *<= ?x" + "setleD"; "[| (?S::?'a set) *<= (?x::?'a); (?y::?'a) : ?S |] ==> ?y <= ?x" + "setgeI"; "Ball (?S::?'a set) (op <= (?x::?'a)) ==> ?x <=* ?S" + "setgeD"; "[| (?x::?'a) <=* (?S::?'a set); (?y::?'a) : ?S |] ==> ?x <= ?y" + "leastPD1"; + "leastPD2"; + "leastPD3"; + "isLubD1"; + "isLubD1a"; + "isLub_isUb"; + "isLubD2"; + "isLubD3"; + "isLubI1"; + "isLubI2"; + "isUbD"; + "[| isUb (?R::?'a set) (?S::?'a set) (?x::?'a); (?y::?'a) : ?S |] + ==> ?y <= ?x" "isUbD2"; + "isUbD2a"; + "isUbI"; + "isLub_le_isUb"; + "isLub_ubs"; +PNat.ML:qed ------------------------------------------------------------------ + "pnat_fun_mono"; "mono (%X::nat set. {Suc (0::nat)} Un Suc ` X)" + "one_RepI"; "Suc (0::nat) : pnat" + "pnat_Suc_RepI"; + "two_RepI"; + "PNat_induct"; + "[| (?i::nat) : pnat; (?P::nat => bool) (Suc (0::nat)); + !!j::nat. [| j : pnat; ?P j |] ==> ?P (Suc j) |] ==> ?P ?i" + "pnat_induct"; + "[| (?P::pnat => bool) (1::pnat); !!n::pnat. ?P n ==> ?P (pSuc n) |] + ==> ?P (?n::pnat)" + "pnat_diff_induct"; + "pnatE"; + "inj_on_Abs_pnat"; + "inj_Rep_pnat"; + "zero_not_mem_pnat"; + "mem_pnat_gt_zero"; + "gt_0_mem_pnat"; + "mem_pnat_gt_0_iff"; + "Rep_pnat_gt_zero"; + "pnat_add_commute"; "(?x::pnat) + (?y::pnat) = ?y + ?x" + "Collect_pnat_gt_0"; + "pSuc_not_one"; + "inj_pSuc"; + "pSuc_pSuc_eq"; + "n_not_pSuc_n"; + "not1_implies_pSuc"; + "pSuc_is_plus_one"; + "sum_Rep_pnat"; + "sum_Rep_pnat_sum"; + "pnat_add_assoc"; + "pnat_add_left_commute"; + "pnat_add_left_cancel"; + "pnat_add_right_cancel"; + "pnat_no_add_ident"; + "pnat_less_not_refl"; + "pnat_less_not_refl2"; + "Rep_pnat_not_less0"; + "Rep_pnat_not_less_one"; + "Rep_pnat_gt_implies_not0"; + "pnat_less_linear"; + "Rep_pnat_le_one"; + "lemma_less_ex_sum_Rep_pnat"; + "pnat_le_iff_Rep_pnat_le"; + "pnat_add_left_cancel_le"; + "pnat_add_left_cancel_less"; + "pnat_add_lessD1"; + "pnat_not_add_less1"; + "pnat_not_add_less2"; +PNat.ML:qed_spec_mp + "pnat_add_leD1"; + "pnat_add_leD2"; +PNat.ML:qed + "pnat_less_add_eq_less"; + "pnat_less_iff"; + "pnat_linear_Ex_eq"; + "pnat_eq_lessI"; + "Rep_pnat_mult_1"; + "Rep_pnat_mult_1_right"; + "mult_Rep_pnat"; + "mult_Rep_pnat_mult"; + "pnat_mult_commute"; "(?m::pnat) * (?n::pnat) = ?n * ?m" + "pnat_add_mult_distrib"; + "pnat_add_mult_distrib2"; + "pnat_mult_assoc"; + "pnat_mult_left_commute"; + "pnat_mult_1"; + "pnat_mult_1_left"; + "pnat_mult_less_mono2"; + "pnat_mult_less_mono1"; + "pnat_mult_less_cancel2"; + "pnat_mult_less_cancel1"; + "pnat_mult_cancel2"; + "pnat_mult_cancel1"; + "pnat_same_multI2"; + "eq_Abs_pnat"; + "pnat_one_iff"; + "pnat_two_eq"; + "inj_pnat_of_nat"; + "nat_add_one_less"; + "nat_add_one_less1"; + "pnat_of_nat_add"; + "pnat_of_nat_less_iff"; + "pnat_of_nat_mult"; +PRat.ML:qed ------------------------------------------------------------------ + "prat_trans_lemma"; + "[| (?x1.0::pnat) * (?y2.0::pnat) = (?x2.0::pnat) * (?y1.0::pnat); + ?x2.0 * (?y3.0::pnat) = (?x3.0::pnat) * ?y2.0 |] + ==> ?x1.0 * ?y3.0 = ?x3.0 * ?y1.0" + "ratrel_iff"; + "ratrelI"; + "ratrelE_lemma"; + "ratrelE"; + "ratrel_refl"; + "equiv_ratrel"; + "ratrel_in_prat"; + "inj_on_Abs_prat"; + "inj_Rep_prat"; + "inj_prat_of_pnat"; + "eq_Abs_prat"; + "qinv_congruent"; + "qinv"; + "qinv_qinv"; + "inj_qinv"; + "qinv_1"; + "prat_add_congruent2_lemma"; + "prat_add_congruent2"; + "prat_add"; + "prat_add_commute"; + "prat_add_assoc"; + "prat_add_left_commute"; + "pnat_mult_congruent2"; + "prat_mult"; + "prat_mult_commute"; + "prat_mult_assoc"; + "prat_mult_left_commute"; + "prat_mult_1"; + "prat_mult_1_right"; + "prat_of_pnat_add"; + "prat_of_pnat_mult"; + "prat_mult_qinv"; + "prat_mult_qinv_right"; + "prat_qinv_ex"; + "prat_qinv_ex1"; + "prat_qinv_left_ex1"; + "prat_mult_inv_qinv"; + "prat_as_inverse_ex"; + "qinv_mult_eq"; + "prat_add_mult_distrib"; + "prat_add_mult_distrib2"; + "prat_less_iff"; + "prat_lessI"; + "prat_lessE_lemma"; + "prat_lessE"; + "prat_less_trans"; + "prat_less_not_refl"; + "prat_less_not_sym"; + "lemma_prat_dense"; + "prat_lemma_dense"; + "prat_dense"; + "prat_add_less2_mono1"; + "prat_add_less2_mono2"; + "prat_mult_less2_mono1"; + "prat_mult_left_less2_mono1"; + "lemma_prat_add_mult_mono"; + "qless_Ex"; + "lemma_prat_less_linear"; + "prat_linear"; + "prat_linear_less2"; + "lemma1_qinv_prat_less"; + "lemma2_qinv_prat_less"; + "qinv_prat_less"; + "prat_qinv_gt_1"; + "prat_qinv_is_gt_1"; + "prat_less_1_2"; + "prat_less_qinv_2_1"; + "prat_mult_qinv_less_1"; + "prat_self_less_add_self"; + "prat_self_less_add_right"; + "prat_self_less_add_left"; + "prat_self_less_mult_right"; + "prat_leI"; + "prat_leD"; + "prat_less_le_iff"; + "not_prat_leE"; + "prat_less_imp_le"; + "prat_le_imp_less_or_eq"; + "prat_less_or_eq_imp_le"; + "prat_le_eq_less_or_eq"; + "prat_le_refl"; + "prat_le_less_trans"; + "prat_le_trans"; + "not_less_not_eq_prat_less"; + "prat_add_less_mono"; + "prat_mult_less_mono"; + "prat_mult_left_le2_mono1"; + "prat_mult_le2_mono1"; + "qinv_prat_le"; + "prat_add_left_le2_mono1"; + "prat_add_le2_mono1"; + "prat_add_le_mono"; + "prat_add_right_less_cancel"; + "prat_add_left_less_cancel"; + "Abs_prat_mult_qinv"; + "lemma_Abs_prat_le1"; + "lemma_Abs_prat_le2"; + "lemma_Abs_prat_le3"; + "pre_lemma_gleason9_34"; + "pre_lemma_gleason9_34b"; + "prat_of_pnat_less_iff"; + "lemma_prat_less_1_memEx"; + "lemma_prat_less_1_set_non_empty"; + "empty_set_psubset_lemma_prat_less_1_set"; + "lemma_prat_less_1_not_memEx"; + "lemma_prat_less_1_set_not_rat_set"; + "lemma_prat_less_1_set_psubset_rat_set"; + "preal_1"; + "{x::prat. x < prat_of_pnat (Abs_pnat (Suc (0::nat)))} + : {A::prat set. + {} < A & + A < UNIV & + (ALL y::prat:A. (ALL z::prat. z < y --> z : A) & Bex A (op < y))}" +PReal.ML:qed ----------------------------------------------------------------- + "inj_on_Abs_preal"; "inj_on Abs_preal preal" + "inj_Rep_preal"; + "empty_not_mem_preal"; + "one_set_mem_preal"; + "preal_psubset_empty"; + "Rep_preal_psubset_empty"; + "mem_Rep_preal_Ex"; + "prealI1"; + "[| {} < (?A::prat set); ?A < UNIV; + ALL y::prat:?A. (ALL z::prat. z < y --> z : ?A) & Bex ?A (op < y) |] + ==> ?A : preal" + "prealI2"; + "prealE_lemma"; + "prealE_lemma1"; + "prealE_lemma2"; + "prealE_lemma3"; + "prealE_lemma3a"; + "prealE_lemma3b"; + "prealE_lemma4"; + "prealE_lemma4a"; + "not_mem_Rep_preal_Ex"; + "lemma_prat_less_set_mem_preal"; + "lemma_prat_set_eq"; + "inj_preal_of_prat"; + "not_in_preal_ub"; + "preal_less_not_refl"; + "preal_not_refl2"; + "preal_less_trans"; + "preal_less_not_sym"; + "preal_linear"; + "(?r1.0::preal) < (?r2.0::preal) | ?r1.0 = ?r2.0 | ?r2.0 < ?r1.0" + "preal_linear_less2"; + "preal_add_commute"; "(?x::preal) + (?y::preal) = ?y + ?x" + "preal_add_set_not_empty"; + "preal_not_mem_add_set_Ex"; + "preal_add_set_not_prat_set"; + "preal_add_set_lemma3"; + "preal_add_set_lemma4"; + "preal_mem_add_set"; + "preal_add_assoc"; + "preal_add_left_commute"; + "preal_mult_commute"; "(?x::preal) * (?y::preal) = ?y * ?x" + "preal_mult_set_not_empty"; + "preal_not_mem_mult_set_Ex"; + "preal_mult_set_not_prat_set"; + "preal_mult_set_lemma3"; + "preal_mult_set_lemma4"; + "preal_mem_mult_set"; + "preal_mult_assoc"; + "preal_mult_left_commute"; + "preal_mult_1"; + "preal_mult_1_right"; + "preal_add_assoc_cong"; + "preal_add_assoc_swap"; + "mem_Rep_preal_addD"; + "mem_Rep_preal_addI"; + "mem_Rep_preal_add_iff"; + "mem_Rep_preal_multD"; + "mem_Rep_preal_multI"; + "mem_Rep_preal_mult_iff"; + "lemma_add_mult_mem_Rep_preal"; + "lemma_add_mult_mem_Rep_preal1"; + "lemma_preal_add_mult_distrib"; + "lemma_preal_add_mult_distrib2"; + "preal_add_mult_distrib2"; + "preal_add_mult_distrib"; + "qinv_not_mem_Rep_preal_Ex"; + "lemma_preal_mem_inv_set_ex"; + "preal_inv_set_not_empty"; + "qinv_mem_Rep_preal_Ex"; + "preal_not_mem_inv_set_Ex"; + "preal_inv_set_not_prat_set"; + "preal_inv_set_lemma3"; + "preal_inv_set_lemma4"; + "preal_mem_inv_set"; + "preal_mem_mult_invD"; + "lemma1_gleason9_34"; + "lemma1b_gleason9_34"; + "lemma_gleason9_34a"; + "lemma_gleason9_34"; + "lemma1_gleason9_36"; + "lemma2_gleason9_36"; + "lemma_gleason9_36"; + "lemma_gleason9_36a"; + "preal_mem_mult_invI"; + "preal_mult_inv"; + "preal_mult_inv_right"; + "eq_Abs_preal"; + "Rep_preal_self_subset"; + "Rep_preal_sum_not_subset"; + "Rep_preal_sum_not_eq"; + "preal_self_less_add_left"; + "preal_self_less_add_right"; + "preal_leD"; + "not_preal_leE"; + "preal_leI"; + "preal_less_le_iff"; + "preal_less_imp_le"; + "preal_le_imp_less_or_eq"; + "preal_less_or_eq_imp_le"; + "preal_le_refl"; + "preal_le_trans"; + "preal_le_anti_sym"; + "preal_neq_iff"; + "preal_less_le"; + "lemma_psubset_mem"; + "lemma_psubset_not_refl"; + "psubset_trans"; + "subset_psubset_trans"; + "subset_psubset_trans2"; + "psubsetD"; + "lemma_ex_mem_less_left_add1"; + "preal_less_set_not_empty"; + "lemma_ex_not_mem_less_left_add1"; + "preal_less_set_not_prat_set"; + "preal_less_set_lemma3"; + "preal_less_set_lemma4"; + "preal_mem_less_set"; + "preal_less_add_left_subsetI"; + "lemma_sum_mem_Rep_preal_ex"; + "preal_less_add_left_subsetI2"; + "preal_less_add_left"; + "preal_less_add_left_Ex"; + "preal_add_less2_mono1"; + "preal_add_less2_mono2"; + "preal_mult_less_mono1"; + "preal_mult_left_less_mono1"; + "preal_mult_left_le_mono1"; + "preal_mult_le_mono1"; + "preal_add_left_le_mono1"; + "preal_add_le_mono1"; + "preal_add_right_less_cancel"; + "preal_add_left_less_cancel"; + "preal_add_less_iff1"; + "preal_add_less_iff2"; + "preal_add_less_mono"; + "preal_mult_less_mono"; + "preal_add_right_cancel"; + "preal_add_left_cancel"; + "preal_add_left_cancel_iff"; + "preal_add_right_cancel_iff"; + "preal_sup_mem_Ex"; + "preal_sup_set_not_empty"; + "preal_sup_not_mem_Ex"; + "preal_sup_not_mem_Ex1"; + "preal_sup_set_not_prat_set"; + "preal_sup_set_not_prat_set1"; + "preal_sup_set_lemma3"; + "preal_sup_set_lemma3_1"; + "preal_sup_set_lemma4"; + "preal_sup_set_lemma4_1"; + "preal_sup"; + "preal_sup1"; + "preal_psup_leI"; + "preal_psup_leI2"; + "preal_psup_leI2b"; + "preal_psup_leI2a"; + "psup_le_ub"; + "psup_le_ub1"; + "preal_complete"; + "lemma_preal_rat_less"; + "lemma_preal_rat_less2"; + "preal_of_prat_add"; + "lemma_preal_rat_less3"; + "lemma_preal_rat_less4"; + "preal_of_prat_mult"; + "preal_of_prat_less_iff"; "(preal_of_prat ?p < preal_of_prat ?q) = (?p < ?q)" +RealDef.ML:qed --------------------------------------------------------------- + "preal_trans_lemma"; + "realrel_iff"; + "realrelI"; + "?x1.0 + ?y2.0 = ?x2.0 + ?y1.0 ==> ((?x1.0, ?y1.0), ?x2.0, ?y2.0) : realrel" + "realrelE_lemma"; + "realrelE"; + "realrel_refl"; + "equiv_realrel"; + "realrel_in_real"; + "inj_on_Abs_REAL"; + "inj_Rep_REAL"; + "inj_real_of_preal"; + "eq_Abs_REAL"; + "real_minus_congruent"; + "real_minus"; + "- Abs_REAL (realrel `` {(?x, ?y)}) = Abs_REAL (realrel `` {(?y, ?x)})" + "real_minus_minus"; (**)"- (- (?z::real)) = ?z" + "inj_real_minus"; "inj uminus" + "real_minus_zero"; (**)"- 0 = 0" + "real_minus_zero_iff"; (**)"(- ?x = 0) = (?x = 0)" + "real_add_congruent2"; + "congruent2 realrel + (%p1 p2. (%(x1, y1). (%(x2, y2). realrel `` {(x1 + x2, y1 + y2)}) p2) p1)" + "real_add"; + "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) + + Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) = + Abs_REAL (realrel `` {(?x1.0 + ?x2.0, ?y1.0 + ?y2.0)})" + "real_add_commute"; (**)"(?z::real) + (?w::real) = ?w + ?z" + "real_add_assoc"; (**) + "real_add_left_commute"; (**) + "real_add_zero_left"; (**)"0 + ?z = ?z" + "real_add_zero_right"; (**) + "real_add_minus"; (**)"?z + - ?z = 0" + "real_add_minus_left"; (**) + "real_add_minus_cancel"; (**)"?z + (- ?z + ?w) = ?w" + "real_minus_add_cancel"; (**)"- ?z + (?z + ?w) = ?w" + "real_minus_ex"; "EX y. ?x + y = 0" + "real_minus_ex1"; + "real_minus_left_ex1"; "EX! y. y + ?x = 0" + "real_add_minus_eq_minus";"?x + ?y = 0 ==> ?x = - ?y" + "real_as_add_inverse_ex"; "EX y. ?x = - y" + "real_minus_add_distrib"; (**)"- (?x + ?y) = - ?x + - ?y" + "real_add_left_cancel"; "(?x + ?y = ?x + ?z) = (?y = ?z)" + "real_add_right_cancel"; "(?y + ?x = ?z + ?x) = (?y = ?z)" + "real_diff_0"; (**)"0 - ?x = - ?x" + "real_diff_0_right"; (**)"?x - 0 = ?x" + "real_diff_self"; (**)"?x - ?x = 0" + "real_mult_congruent2_lemma"; + "real_mult_congruent2"; + "congruent2 realrel + (%p1 p2. + (%(x1, y1). + (%(x2, y2). realrel `` {(x1 * x2 + y1 * y2, x1 * y2 + x2 * y1)}) + p2) p1)" + "real_mult"; + "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) * + Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) = + Abs_REAL + (realrel `` + {(?x1.0 * ?x2.0 + ?y1.0 * ?y2.0, ?x1.0 * ?y2.0 + ?x2.0 * ?y1.0)})" + "real_mult_commute"; (**)"?z * ?w = ?w * ?z" + "real_mult_assoc"; (**) + "real_mult_left_commute"; + (**)"?z1.0 * (?z2.0 * ?z3.0) = ?z2.0 * (?z1.0 * ?z3.0)" + "real_mult_1"; (**)"1 * ?z = ?z" + "real_mult_1_right"; (**)"?z * 1 = ?z" + "real_mult_0"; (**) + "real_mult_0_right"; (**)"?z * 0 = 0" + "real_mult_minus_eq1"; (**)"- ?x * ?y = - (?x * ?y)" + "real_mult_minus_eq2"; (**)"?x * - ?y = - (?x * ?y)" + "real_mult_minus_1"; (**)"- 1 * ?z = - ?z" + "real_mult_minus_1_right";(**)"?z * - 1 = - ?z" + "real_minus_mult_cancel"; (**)"- ?x * - ?y = ?x * ?y" + "real_minus_mult_commute";(**)"- ?x * ?y = ?x * - ?y" + "real_add_assoc_cong"; + "?z + ?v = ?z' + ?v' ==> ?z + (?v + ?w) = ?z' + (?v' + ?w)" + "real_add_assoc_swap"; (**)"?z + (?v + ?w) = ?v + (?z + ?w)" + "real_add_mult_distrib"; (**)"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w" + "real_add_mult_distrib2"; (**)"?w * (?z1.0 + ?z2.0) = ?w * ?z1.0 + ?w * ?z2.0" + "real_diff_mult_distrib"; (**)"(?z1.0 - ?z2.0) * ?w = ?z1.0 * ?w - ?z2.0 * ?w" + "real_diff_mult_distrib2";(**)"?w * (?z1.0 - ?z2.0) = ?w * ?z1.0 - ?w * ?z2.0" + "real_zero_not_eq_one"; + "real_zero_iff"; "0 = Abs_REAL (realrel `` {(?x, ?x)})" + "real_mult_inv_right_ex"; "?x ~= 0 ==> EX y. ?x * y = 1" + "real_mult_inv_left_ex"; "?x ~= 0 ==> inverse ?x * ?x = 1" + "real_mult_inv_left"; + "real_mult_inv_right"; "?x ~= 0 ==> ?x * inverse ?x = 1" + "INVERSE_ZERO"; "inverse 0 = 0" + "DIVISION_BY_ZERO"; (*NOT for adding to default simpset*)"?a / 0 = 0" + "real_mult_left_cancel"; (**)"?c ~= 0 ==> (?c * ?a = ?c * ?b) = (?a = ?b)" + "real_mult_right_cancel"; (**)"?c ~= 0 ==> (?a * ?c = ?b * ?c) = (?a = ?b)" + "real_mult_left_cancel_ccontr"; "?c * ?a ~= ?c * ?b ==> ?a ~= ?b" + "real_mult_right_cancel_ccontr"; "?a * ?c ~= ?b * ?c ==> ?a ~= ?b" + "real_inverse_not_zero"; "?x ~= 0 ==> inverse ?x ~= 0" + "real_mult_not_zero"; "[| ?x ~= 0; ?y ~= 0 |] ==> ?x * ?y ~= 0" + "real_inverse_inverse"; "inverse (inverse ?x) = ?x" + "real_inverse_1"; "inverse 1 = 1" + "real_minus_inverse"; "inverse (- ?x) = - inverse ?x" + "real_inverse_distrib"; "inverse (?x * ?y) = inverse ?x * inverse ?y" + "real_times_divide1_eq"; (**)"?x * (?y / ?z) = ?x * ?y / ?z" + "real_times_divide2_eq"; (**)"?y / ?z * ?x = ?y * ?x / ?z" + "real_divide_divide1_eq"; (**)"?x / (?y / ?z) = ?x * ?z / ?y" + "real_divide_divide2_eq"; (**)"?x / ?y / ?z = ?x / (?y * ?z)" + "real_minus_divide_eq"; (**)"- ?x / ?y = - (?x / ?y)" + "real_divide_minus_eq"; (**)"?x / - ?y = - (?x / ?y)" + "real_add_divide_distrib"; (**)"(?x + ?y) / ?z = ?x / ?z + ?y / ?z" + "preal_lemma_eq_rev_sum"; + "[| ?x = ?y; ?x1.0 = ?y1.0 |] ==> ?x + ?y1.0 = ?x1.0 + ?y" + "preal_add_left_commute_cancel"; + "?x + (?b + ?y) = ?x1.0 + (?b + ?y1.0) ==> ?x + ?y = ?x1.0 + ?y1.0" + "preal_lemma_for_not_refl"; + "real_less_not_refl"; "~ ?R < ?R" + "real_not_refl2"; + "preal_lemma_trans"; + "real_less_trans"; + "real_less_not_sym"; + "real_of_preal_add"; + "real_of_preal (?z1.0 + ?z2.0) = real_of_preal ?z1.0 + real_of_preal ?z2.0" + "real_of_preal_mult"; + "real_of_preal_ExI"; + "real_of_preal_ExD"; + "real_of_preal_iff"; + "real_of_preal_trichotomy"; + "real_of_preal_trichotomyE"; + "real_of_preal_lessD"; + "real_of_preal_lessI"; + "?m1.0 < ?m2.0 ==> real_of_preal ?m1.0 < real_of_preal ?m2.0" + "real_of_preal_less_iff1"; + "real_of_preal_minus_less_self"; + "real_of_preal_minus_less_zero"; + "real_of_preal_not_minus_gt_zero"; + "real_of_preal_zero_less"; + "real_of_preal_not_less_zero"; + "real_minus_minus_zero_less"; + "real_of_preal_sum_zero_less"; + "real_of_preal_minus_less_all"; + "real_of_preal_not_minus_gt_all"; + "real_of_preal_minus_less_rev1"; + "real_of_preal_minus_less_rev2"; + "real_of_preal_minus_less_rev_iff"; + "real_linear"; "?R1.0 < ?R2.0 | ?R1.0 = ?R2.0 | ?R2.0 < ?R1.0" + "real_neq_iff"; + "real_linear_less2"; + "[| ?R1.0 < ?R2.0 ==> ?P; ?R1.0 = ?R2.0 ==> ?P; ?R2.0 < ?R1.0 ==> ?P |] + ==> ?P" + "real_leI"; + "real_leD"; "~ ?w < ?z ==> ?z <= ?w" + "real_less_le_iff"; + "not_real_leE"; + "real_le_imp_less_or_eq"; + "real_less_or_eq_imp_le"; + "real_le_less"; + "real_le_refl"; "?w <= ?w" + "real_le_linear"; + "real_le_trans"; "[| ?i <= ?j; ?j <= ?k |] ==> ?i <= ?k" + "real_le_anti_sym"; "[| ?z <= ?w; ?w <= ?z |] ==> ?z = ?w" + "not_less_not_eq_real_less"; + "real_less_le"; "(?w < ?z) = (?w <= ?z & ?w ~= ?z)" + "real_minus_zero_less_iff"; + "real_minus_zero_less_iff2"; + "real_less_add_positive_left_Ex"; + "real_less_sum_gt_zero"; "?W < ?S ==> 0 < ?S + - ?W" + "real_lemma_change_eq_subj"; + "real_sum_gt_zero_less"; "0 < ?S + - ?W ==> ?W < ?S" + "real_less_sum_gt_0_iff"; "(0 < ?S + - ?W) = (?W < ?S)" + "real_less_eq_diff"; "(?x < ?y) = (?x - ?y < 0)" + "real_add_diff_eq"; (**)"?x + (?y - ?z) = ?x + ?y - ?z" + "real_diff_add_eq"; (**)"?x - ?y + ?z = ?x + ?z - ?y" + "real_diff_diff_eq"; (**)"?x - ?y - ?z = ?x - (?y + ?z)" + "real_diff_diff_eq2"; (**)"?x - (?y - ?z) = ?x + ?z - ?y" + "real_diff_less_eq"; "(?x - ?y < ?z) = (?x < ?z + ?y)" + "real_less_diff_eq"; + "real_diff_le_eq"; "(?x - ?y <= ?z) = (?x <= ?z + ?y)" + "real_le_diff_eq"; + "real_diff_eq_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)" + "real_eq_diff_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)" + "real_less_eqI"; + "real_le_eqI"; + "real_eq_eqI"; "?x - ?y = ?x' - ?y' ==> (?x = ?y) = (?x' = ?y')" +RealOrd.ML:qed --------------------------------------------------------------- + "real_add_cancel_21"; "(?x + (?y + ?z) = ?y + ?u) = (?x + ?z = ?u)" + "real_add_cancel_end"; "(?x + (?y + ?z) = ?y) = (?x = - ?z)" + "real_minus_diff_eq"; (*??*)"- (?x - ?y) = ?y - ?x" + "real_gt_zero_preal_Ex"; + "real_gt_preal_preal_Ex"; + "real_ge_preal_preal_Ex"; + "real_less_all_preal"; "?y <= 0 ==> ALL x. ?y < real_of_preal x" + "real_less_all_real2"; + "real_lemma_add_positive_imp_less"; + "real_ex_add_positive_left_less";"EX T. 0 < T & ?R + T = ?S ==> ?R < ?S" + "real_less_iff_add"; + "real_of_preal_le_iff"; + "real_mult_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x * ?y" + "neg_real_mult_order"; + "real_mult_less_0"; "[| 0 < ?x; ?y < 0 |] ==> ?x * ?y < 0" + "real_zero_less_one"; "0 < 1" + "real_add_right_cancel_less"; "(?v + ?z < ?w + ?z) = (?v < ?w)" + "real_add_left_cancel_less"; + "real_add_right_cancel_le"; + "real_add_left_cancel_le"; + "real_add_less_le_mono"; "[| ?w' < ?w; ?z' <= ?z |] ==> ?w' + ?z' < ?w + ?z" + "real_add_le_less_mono"; "[| ?w' <= ?w; ?z' < ?z |] ==> ?w' + ?z' < ?w + ?z" + "real_add_less_mono2"; + "real_less_add_right_cancel"; + "real_less_add_left_cancel"; "?C + ?A < ?C + ?B ==> ?A < ?B" + "real_le_add_right_cancel"; + "real_le_add_left_cancel"; "?C + ?A <= ?C + ?B ==> ?A <= ?B" + "real_add_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x + ?y" + "real_le_add_order"; + "real_add_less_mono"; + "real_add_left_le_mono1"; + "real_add_le_mono"; + "real_less_Ex"; + "real_add_minus_positive_less_self"; "0 < ?r ==> ?u + - ?r < ?u" + "real_le_minus_iff"; "(- ?s <= - ?r) = (?r <= ?s)" + "real_le_square"; + "real_of_posnat_one"; + "real_of_posnat_two"; + "real_of_posnat_add"; "real_of_posnat ?n1.0 + real_of_posnat ?n2.0 = + real_of_posnat (?n1.0 + ?n2.0) + 1" + "real_of_posnat_add_one"; + "real_of_posnat_Suc"; + "inj_real_of_posnat"; + "real_of_nat_zero"; + "real_of_nat_one"; "real (Suc 0) = 1" + "real_of_nat_add"; + "real_of_nat_Suc"; + "real_of_nat_less_iff"; + "real_of_nat_le_iff"; + "inj_real_of_nat"; + "real_of_nat_ge_zero"; + "real_of_nat_mult"; + "real_of_nat_inject"; +RealOrd.ML:qed_spec_mp + "real_of_nat_diff"; +RealOrd.ML:qed + "real_of_nat_zero_iff"; + "real_of_nat_neg_int"; + "real_inverse_gt_0"; + "real_inverse_less_0"; + "real_mult_less_mono1"; + "real_mult_less_mono2"; + "real_mult_less_cancel1"; + "(?k * ?m < ?k * ?n) = (0 < ?k & ?m < ?n | ?k < 0 & ?n < ?m)" + "real_mult_less_cancel2"; + "real_mult_less_iff1"; + "real_mult_less_iff2"; + "real_mult_le_cancel_iff1"; + "real_mult_le_cancel_iff2"; + "real_mult_le_less_mono1"; + "real_mult_less_mono"; + "real_mult_less_mono'"; + "real_gt_zero"; "1 <= ?x ==> 0 < ?x" + "real_mult_self_le"; "[| 1 < ?r; 1 <= ?x |] ==> ?x <= ?r * ?x" + "real_mult_self_le2"; + "real_inverse_less_swap"; + "real_mult_is_0"; + "real_inverse_add"; + "real_minus_zero_le_iff"; + "real_minus_zero_le_iff2"; + "real_sum_squares_cancel"; "?x * ?x + ?y * ?y = 0 ==> ?x = 0" + "real_sum_squares_cancel2"; "?x * ?x + ?y * ?y = 0 ==> ?y = 0" + "real_0_less_mult_iff"; + "real_0_le_mult_iff"; + "real_mult_less_0_iff"; "(?x * ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)" + "real_mult_le_0_iff"; +RealInt.ML:qed --------------------------------------------------------------- + "real_of_int_congruent"; + "real_of_int"; "real (Abs_Integ (intrel `` {(?i, ?j)})) = + Abs_REAL + (realrel `` + {(preal_of_prat (prat_of_pnat (pnat_of_nat ?i)), + preal_of_prat (prat_of_pnat (pnat_of_nat ?j)))})" + "inj_real_of_int"; + "real_of_int_zero"; + "real_of_one"; + "real_of_int_add"; "real ?x + real ?y = real (?x + ?y)" + "real_of_int_minus"; + "real_of_int_diff"; + "real_of_int_mult"; "real ?x * real ?y = real (?x * ?y)" + "real_of_int_Suc"; + "real_of_int_real_of_nat"; + "real_of_nat_real_of_int"; + "real_of_int_zero_cancel"; + "real_of_int_less_cancel"; + "real_of_int_inject"; + "real_of_int_less_mono"; + "real_of_int_less_iff"; + "real_of_int_le_iff"; +RealBin.ML:qed --------------------------------------------------------------- + "real_number_of"; "real (number_of ?w) = number_of ?w" + "real_numeral_0_eq_0"; + "real_numeral_1_eq_1"; + "add_real_number_of"; + "minus_real_number_of"; + "diff_real_number_of"; + "mult_real_number_of"; + "real_mult_2"; (**)"2 * ?z = ?z + ?z" + "real_mult_2_right"; (**)"?z * 2 = ?z + ?z" + "eq_real_number_of"; + "less_real_number_of"; + "le_real_number_of_eq_not_less"; + "real_minus_1_eq_m1"; "- 1 = -1"(*uminus.. = "-.."*) + "real_mult_minus1"; (**)"-1 * ?z = - ?z" + "real_mult_minus1_right"; (**)"?z * -1 = - ?z" + "zero_less_real_of_nat_iff";"(0 < real ?n) = (0 < ?n)" + "zero_le_real_of_nat_iff"; + "real_add_number_of_left"; + "real_mult_number_of_left"; + "number_of ?v * (number_of ?w * ?z) = number_of (bin_mult ?v ?w) * ?z" + "real_add_number_of_diff1"; + "real_add_number_of_diff2";"number_of ?v + (?c - number_of ?w) = + number_of (bin_add ?v (bin_minus ?w)) + ?c" + "real_of_nat_number_of"; + "real (number_of ?v) = (if neg (number_of ?v) then 0 else number_of ?v)" + "real_less_iff_diff_less_0"; "(?x < ?y) = (?x - ?y < 0)" + "real_eq_iff_diff_eq_0"; + "real_le_iff_diff_le_0"; + "left_real_add_mult_distrib"; + (**)"?i * ?u + (?j * ?u + ?k) = (?i + ?j) * ?u + ?k" + "real_eq_add_iff1"; + "(?i * ?u + ?m = ?j * ?u + ?n) = ((?i - ?j) * ?u + ?m = ?n)" + "real_eq_add_iff2"; + "real_less_add_iff1"; + "real_less_add_iff2"; + "real_le_add_iff1"; + "real_le_add_iff2"; + "real_mult_le_mono1"; + "real_mult_le_mono2"; + "real_mult_le_mono"; + "[| ?i <= ?j; ?k <= ?l; 0 <= ?j; 0 <= ?k |] ==> ?i * ?k <= ?j * ?l" +RealArith0.ML:qed ------------------------------------------------------------ + "real_diff_minus_eq"; (**)"?x - - ?y = ?x + ?y" + "real_0_divide"; (**)"0 / ?x = 0" + "real_0_less_inverse_iff"; "(0 < inverse ?x) = (0 < ?x)" + "real_inverse_less_0_iff"; + "real_0_le_inverse_iff"; + "real_inverse_le_0_iff"; + "REAL_DIVIDE_ZERO"; "?x / 0 = 0"(*!!!*) + "real_inverse_eq_divide"; + "real_0_less_divide_iff";"(0 < ?x / ?y) = (0 < ?x & 0 < ?y | ?x < 0 & ?y < 0)" + "real_divide_less_0_iff";"(?x / ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)" + "real_0_le_divide_iff"; + "real_divide_le_0_iff"; + "(?x / ?y <= 0) = ((?x <= 0 | ?y <= 0) & (0 <= ?x | 0 <= ?y))" + "real_inverse_zero_iff"; + "real_divide_eq_0_iff"; "(?x / ?y = 0) = (?x = 0 | ?y = 0)"(*!!!*) + "real_divide_self_eq"; "?h ~= 0 ==> ?h / ?h = 1"(**) + "real_minus_less_minus"; "(- ?y < - ?x) = (?x < ?y)" + "real_mult_less_mono1_neg"; "[| ?i < ?j; ?k < 0 |] ==> ?j * ?k < ?i * ?k" + "real_mult_less_mono2_neg"; + "real_mult_le_mono1_neg"; + "real_mult_le_mono2_neg"; + "real_mult_less_cancel2"; + "real_mult_le_cancel2"; + "real_mult_less_cancel1"; + "real_mult_le_cancel1"; + "real_mult_eq_cancel1"; "(?k * ?m = ?k * ?n) = (?k = 0 | ?m = ?n)" + "real_mult_eq_cancel2"; "(?m * ?k = ?n * ?k) = (?k = 0 | ?m = ?n)" + "real_mult_div_cancel1"; (**)"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n" + "real_mult_div_cancel_disj"; + "?k * ?m / (?k * ?n) = (if ?k = 0 then 0 else ?m / ?n)" + "pos_real_le_divide_eq"; + "neg_real_le_divide_eq"; + "pos_real_divide_le_eq"; + "neg_real_divide_le_eq"; + "pos_real_less_divide_eq"; + "neg_real_less_divide_eq"; + "pos_real_divide_less_eq"; + "neg_real_divide_less_eq"; + "real_eq_divide_eq"; (**)"?z ~= 0 ==> (?x = ?y / ?z) = (?x * ?z = ?y)" + "real_divide_eq_eq"; (**)"?z ~= 0 ==> (?y / ?z = ?x) = (?y = ?x * ?z)" + "real_divide_eq_cancel2"; "(?m / ?k = ?n / ?k) = (?k = 0 | ?m = ?n)" + "real_divide_eq_cancel1"; "(?k / ?m = ?k / ?n) = (?k = 0 | ?m = ?n)" + "real_inverse_less_iff"; + "real_inverse_le_iff"; + "real_divide_1"; (**)"?x / 1 = ?x" + "real_divide_minus1"; (**)"?x / -1 = - ?x" + "real_minus1_divide"; (**)"-1 / ?x = - (1 / ?x)" + "real_lbound_gt_zero"; + "[| 0 < ?d1.0; 0 < ?d2.0 |] ==> EX e. 0 < e & e < ?d1.0 & e < ?d2.0" + "real_inverse_eq_iff"; "(inverse ?x = inverse ?y) = (?x = ?y)" + "real_divide_eq_iff"; "(?z / ?x = ?z / ?y) = (?z = 0 | ?x = ?y)" + "real_less_minus"; "(?x < - ?y) = (?y < - ?x)" + "real_minus_less"; "(- ?x < ?y) = (- ?y < ?x)" + "real_le_minus"; + "real_minus_le"; "(- ?x <= ?y) = (- ?y <= ?x)" + "real_equation_minus"; (**)"(?x = - ?y) = (?y = - ?x)" + "real_minus_equation"; (**)"(- ?x = ?y) = (- ?y = ?x)" + "real_add_minus_iff"; (**)"(?x + - ?a = 0) = (?x = ?a)" + "real_minus_eq_cancel"; (**)"(- ?b = - ?a) = (?b = ?a)" + "real_add_eq_0_iff"; (**)"(?x + ?y = 0) = (?y = - ?x)" + "real_add_less_0_iff"; "(?x + ?y < 0) = (?y < - ?x)" + "real_0_less_add_iff"; + "real_add_le_0_iff"; + "real_0_le_add_iff"; + "real_0_less_diff_iff"; "(0 < ?x - ?y) = (?y < ?x)" + "real_0_le_diff_iff"; + "real_minus_diff_eq"; (**)"- (?x - ?y) = ?y - ?x" + "real_less_half_sum"; "?x < ?y ==> ?x < (?x + ?y) / 2" + "real_gt_half_sum"; + "real_dense"; "?x < ?y ==> EX r. ?x < r & r < ?y" +RealArith ///!!!///----------------------------------------------------------- +RComplete.ML:qed ------------------------------------------------------------- + "real_sum_of_halves"; (**)"?x / 2 + ?x / 2 = ?x" + "real_sup_lemma1"; + "real_sup_lemma2"; + "posreal_complete"; + "real_isLub_unique"; + "real_order_restrict"; + "posreals_complete"; + "real_sup_lemma3"; + "lemma_le_swap2"; + "lemma_real_complete2b"; + "reals_complete"; + "real_of_nat_Suc_gt_zero"; + "reals_Archimedean"; "0 < ?x ==> EX n. inverse (real (Suc n)) < ?x" + "reals_Archimedean2"; +RealAbs.ML:qed + "abs_nat_number_of"; + "abs (number_of ?v) = + (if neg (number_of ?v) then number_of (bin_minus ?v) else number_of ?v)" + "abs_split"; + "abs_iff"; + "abs_zero"; "abs 0 = 0" + "abs_one"; + "abs_eqI1"; + "abs_eqI2"; + "abs_minus_eqI2"; + "abs_minus_eqI1"; + "abs_ge_zero"; "0 <= abs ?x" + "abs_idempotent"; "abs (abs ?x) = abs ?x" + "abs_zero_iff"; "(abs ?x = 0) = (?x = 0)" + "abs_ge_self"; "?x <= abs ?x" + "abs_ge_minus_self"; + "abs_mult"; "abs (?x * ?y) = abs ?x * abs ?y" + "abs_inverse"; "abs (inverse ?x) = inverse (abs ?x)" + "abs_mult_inverse"; + "abs_triangle_ineq"; "abs (?x + ?y) <= abs ?x + abs ?y" + "abs_triangle_ineq_four"; + "abs_minus_cancel"; + "abs_minus_add_cancel"; + "abs_triangle_minus_ineq"; +RealAbs.ML:qed_spec_mp + "abs_add_less"; "[| abs ?x < ?r; abs ?y < ?s |] ==> abs (?x + ?y) < ?r + ?s" +RealAbs.ML:qed + "abs_add_minus_less"; + "real_mult_0_less"; "(0 * ?x < ?r) = (0 < ?r)" + "real_mult_less_trans"; + "real_mult_le_less_trans"; + "abs_mult_less"; + "abs_mult_less2"; + "abs_less_gt_zero"; + "abs_minus_one"; "abs -1 = 1" + "abs_disj"; "abs ?x = ?x | abs ?x = - ?x" + "abs_interval_iff"; + "abs_le_interval_iff"; + "abs_add_pos_gt_zero"; + "abs_add_one_gt_zero"; + "abs_not_less_zero"; + "abs_circle"; "abs ?h < abs ?y - abs ?x ==> abs (?x + ?h) < abs ?y" + "abs_le_zero_iff"; + "real_0_less_abs_iff"; + "abs_real_of_nat_cancel"; + "abs_add_one_not_less_self"; + "abs_triangle_ineq_three"; "abs (?w + ?x + ?y) <= abs ?w + abs ?x + abs ?y" + "abs_diff_less_imp_gt_zero"; + "abs_diff_less_imp_gt_zero2"; + "abs_diff_less_imp_gt_zero3"; + "abs_diff_less_imp_gt_zero4"; + "abs_triangle_ineq_minus_cancel"; + "abs_sum_triangle_ineq"; + "abs (?x + ?y + (- ?l + - ?m)) <= abs (?x + - ?l) + abs (?y + - ?m)" +RealPow.ML:qed + "realpow_zero"; "0 ^ Suc ?n = 0" +RealPow.ML:qed_spec_mp + "realpow_not_zero"; "?r ~= 0 ==> ?r ^ ?n ~= 0" + "realpow_zero_zero"; "?r ^ ?n = 0 ==> ?r = 0" + "realpow_inverse"; "inverse (?r ^ ?n) = inverse ?r ^ ?n" + "realpow_abs"; "abs (?r ^ ?n) = abs ?r ^ ?n" + "realpow_add"; (**)"?r ^ (?n + ?m) = ?r ^ ?n * ?r ^ ?m" + "realpow_one"; (**)"?r ^ 1 = ?r" + "realpow_two"; (**)"?r ^ Suc (Suc 0) = ?r * ?r" +RealPow.ML:qed_spec_mp + "realpow_gt_zero"; "0 < ?r ==> 0 < ?r ^ ?n" + "realpow_ge_zero"; "0 <= ?r ==> 0 <= ?r ^ ?n" + "realpow_le"; "0 <= ?x & ?x <= ?y ==> ?x ^ ?n <= ?y ^ ?n" + "realpow_less"; +RealPow.ML:qed + "realpow_eq_one"; (**)"1 ^ ?n = 1" + "abs_realpow_minus_one"; "abs (-1 ^ ?n) = 1" + "realpow_mult"; (**)"(?r * ?s) ^ ?n = ?r ^ ?n * ?s ^ ?n" + "realpow_two_le"; "0 <= ?r ^ Suc (Suc 0)" + "abs_realpow_two"; + "realpow_two_abs"; "abs ?x ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)" + "realpow_two_gt_one"; +RealPow.ML:qed_spec_mp + "realpow_ge_one"; "1 < ?r ==> 1 <= ?r ^ ?n" +RealPow.ML:qed + "realpow_ge_one2"; + "two_realpow_ge_one"; + "two_realpow_gt"; + "realpow_minus_one"; (**)"-1 ^ (2 * ?n) = 1" + "realpow_minus_one_odd"; "-1 ^ Suc (2 * ?n) = - 1" + "realpow_minus_one_even"; +RealPow.ML:qed_spec_mp + "realpow_Suc_less"; + "realpow_Suc_le"; "0 <= ?r & ?r < 1 ==> ?r ^ Suc ?n <= ?r ^ ?n" +RealPow.ML:qed + "realpow_zero_le"; "0 <= 0 ^ ?n" +RealPow.ML:qed_spec_mp + "realpow_Suc_le2"; +RealPow.ML:qed + "realpow_Suc_le3"; +RealPow.ML:qed_spec_mp + "realpow_less_le"; "0 <= ?r & ?r < 1 & ?n < ?N ==> ?r ^ ?N <= ?r ^ ?n" +RealPow.ML:qed + "realpow_le_le"; "[| 0 <= ?r; ?r < 1; ?n <= ?N |] ==> ?r ^ ?N <= ?r ^ ?n" + "realpow_Suc_le_self"; + "realpow_Suc_less_one"; +RealPow.ML:qed_spec_mp + "realpow_le_Suc"; + "realpow_less_Suc"; + "realpow_le_Suc2"; + "realpow_gt_ge"; + "realpow_gt_ge2"; +RealPow.ML:qed + "realpow_ge_ge"; "[| 1 < ?r; ?n <= ?N |] ==> ?r ^ ?n <= ?r ^ ?N" + "realpow_ge_ge2"; +RealPow.ML:qed_spec_mp + "realpow_Suc_ge_self"; + "realpow_Suc_ge_self2"; +RealPow.ML:qed + "realpow_ge_self"; + "realpow_ge_self2"; +RealPow.ML:qed_spec_mp + "realpow_minus_mult"; "0 < ?n ==> ?x ^ (?n - 1) * ?x = ?x ^ ?n" + "realpow_two_mult_inverse"; + "?r ~= 0 ==> ?r * inverse ?r ^ Suc (Suc 0) = inverse ?r" + "realpow_two_minus"; "(- ?x) ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)" + "realpow_two_diff"; + "realpow_two_disj"; + "realpow_diff"; + "[| ?x ~= 0; ?m <= ?n |] ==> ?x ^ (?n - ?m) = ?x ^ ?n * inverse (?x ^ ?m)" + "realpow_real_of_nat"; + "realpow_real_of_nat_two_pos"; "0 < real (Suc (Suc 0) ^ ?n)" +RealPow.ML:qed_spec_mp + "realpow_increasing"; + "realpow_Suc_cancel_eq"; + "[| 0 <= ?x; 0 <= ?y; ?x ^ Suc ?n = ?y ^ Suc ?n |] ==> ?x = ?y" +RealPow.ML:qed + "realpow_eq_0_iff"; "(?x ^ ?n = 0) = (?x = 0 & 0 < ?n)" + "zero_less_realpow_abs_iff"; + "zero_le_realpow_abs"; + "real_of_int_power"; "real ?x ^ ?n = real (?x ^ ?n)" + "power_real_number_of"; "number_of ?v ^ ?n = real (number_of ?v ^ ?n)" +Ring_and_Field ---///!!!///--------------------------------------------------- +Complex_Numbers --///!!!///--------------------------------------------------- +Real -------------///!!!///--------------------------------------------------- +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; +real_arith0.ML:qed ""; + + + + + + + + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/Script.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/Script.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,194 @@ +(* Title: tactics, tacticals etc. for scripts + Author: Walther Neuper 000224 + (c) due to copyright terms + +use_thy_only"ProgLang/Script"; +use_thy"../ProgLang/Script"; +use_thy"Script"; + *) + +theory Script imports Tools begin + +typedecl + ID (* identifiers for thy, ruleset,... *) + +typedecl + arg (* argument of subproblem *) + +consts + +(*types of subproblems' arguments*) + real_' :: "real => arg" + real_list_' :: "(real list) => arg" + real_set_' :: "(real set) => arg" + bool_' :: "bool => arg" + bool_list_' :: "(bool list) => arg" + real_real_' :: "(real => real) => arg" + +(*tactics*) + Rewrite :: "[ID, bool, 'a] => 'a" + Rewrite'_Inst:: "[(real * real) list, ID, bool, 'a] => 'a" + ("(Rewrite'_Inst (_ _ _))" 11) + (*without last argument ^^ for @@*) + Rewrite'_Set :: "[ID, bool, 'a] => 'a" ("(Rewrite'_Set (_ _))" 11) + Rewrite'_Set'_Inst + :: "[(real * real) list, ID, bool, 'a] => 'a" + ("(Rewrite'_Set'_Inst (_ _ _))" 11) + (*without last argument ^^ for @@*) + Calculate :: "[ID, 'a] => 'a" (*WN100816 PLUS, TIMES, POWER miss.in scr*) + Calculate1 :: "[ID, 'a] => 'a" (*FIXXXME: unknown to script-interpreter*) + + (* WN0509 substitution now is rewriting by a list of terms (of type bool) + Substitute :: "[(real * real) list, 'a] => 'a"*) + Substitute :: "[bool list, 'a] => 'a" + + Map :: "['a => 'b, 'a list] => 'b list" + Tac :: "ID => 'a" (*deprecated; only use in Test.ML*) + Check'_elementwise :: + "['a list, 'b set] => 'a list" + ("Check'_elementwise (_ _)" 11) + Take :: "'a => 'a" (*for non-var args as long as no 'o'*) + SubProblem :: "[ID * ID list * ID list, arg list] => 'a" + + Or'_to'_List :: "bool => 'a list" ("Or'_to'_List (_)" 11) + (*=========== record these ^^^ in 'tacs' in Script.ML =========*) + + Assumptions :: bool + Problem :: "[ID * ID list] => 'a" + +(*special formulas for frontend 'CAS format'*) + Subproblem :: "(ID * ID list) => 'a" + +(*script-expressions (tacticals)*) + Seq :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "@@" 10) (*@ used*) + Try :: "['a => 'a, 'a] => 'a" + Repeat :: "['a => 'a, 'a] => 'a" + Or :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "Or" 10) + While :: "[bool, 'a => 'a, 'a] => 'a" ("((While (_) Do)//(_))" 9) +(*WN100723 because of "Error in syntax translation" below... + (*'b => bool doesn't work with "contains_root _"*) + Letpar :: "['a, 'a => 'b] => 'b" + (*--- defined in Isabelle/scr/HOL/HOL.thy: + Let :: "['a, 'a => 'b] => 'b" + "_Let" :: "[letbinds, 'a] => 'a" ("(let (_)/ in (_))" 10) + If :: "[bool, 'a, 'a] => 'a" ("(if (_)/ then (_)/ else (_))" 10) + %x. P x .. lambda is defined in Isabelles meta logic + --- *) +*) + failtac :: 'a + idletac :: 'a + (*... + RECORD IN 'screxpr' in Script.ML *) + +(*for scripts generated automatically from rls*) + Stepwise :: "['z, 'z] => 'z" ("((Script Stepwise (_ =))// (_))" 9) + Stepwise'_inst:: "['z,real,'z] => 'z" + ("((Script Stepwise'_inst (_ _ =))// (_))" 9) + + +(*SHIFT -> resp.thys ----vvv---------------------------------------------*) +(*script-names: initial capital letter, + type of last arg (=script-body) == result-type ! + Xxxx :: script ids, duplicate result-type 'r in last argument: + "['a, ... , \ + \ 'r] => 'r +*) + +(*make'_solution'_set :: "bool => bool list" + ("(make'_solution'_set (_))" 11) + + max'_on'_interval + :: "[ID * (ID list) * ID, bool,real,real set] => real" + ("(max'_on'_interval (_)/ (_ _ _))" 9) + find'_vals + :: "[ID * (ID list) * ID, + real,real,real,real,bool list] => bool list" + ("(find'_vals (_)/ (_ _ _ _ _))" 9) + + make'_fun :: "[ID * (ID list) * ID, real,real,bool list] => bool" + ("(make'_fun (_)/ (_ _ _))" 9) + + solve'_univar + :: "[ID * (ID list) * ID, bool,real] => bool list" + ("(solve'_univar (_)/ (_ _ ))" 9) + solve'_univar'_err + :: "[ID * (ID list) * ID, bool,real,bool] => bool list" + ("(solve'_univar (_)/ (_ _ _))" 9) +----------*) + + Testeq :: "[bool, bool] => bool" + ("((Script Testeq (_ =))// + (_))" 9) + + Testeq2 :: "[bool, bool list] => bool list" + ("((Script Testeq2 (_ =))// + (_))" 9) + + Testterm :: "[real, real] => real" + ("((Script Testterm (_ =))// + (_))" 9) + + Testchk :: "[bool, real, real list] => real list" + ("((Script Testchk (_ _ =))// + (_))" 9) + (*... + RECORD IN 'subpbls' in Script.ML *) +(*SHIFT -> resp.thys ----^^^----------------------------*) + +(*Makarius 10.03 +syntax + + "_Letpar" :: "[letbinds, 'a] => 'a" ("(letpar (_)/ in (_))" 10) + +translations + + "_Letpar (_binds b bs) e" == "_Letpar b (_Letpar bs e)" + "letpar x = a in e" == "Letpar a (%x. e)" +*** Error in syntax translation rule: rhs contains extra variables +*** ("_Letpar" ("_bind" x a) e) -> (Letpar a ("_abs" x e)) +*** At command "translations" (line 140 of "/usr/local/isabisac/src/Pure/isac/Scripts/Script.thy"). +*) + +ML {* (*the former Script.ML*) + +(*.record all theories defined for Scripts; in order to distinguish them + from general IsacKnowledge defined later on.*) +script_thys := !theory'; + +(*--vvv----- SHIFT? or delete ?*) +val IDTyp = Type("Script.ID",[]); + + +val tacs = ref (distinct (remove op = "" + ["Calculate", + "Rewrite","Rewrite'_Inst","Rewrite'_Set","Rewrite'_Set'_Inst", + "Substitute","Tac","Check'_elementswise", + "Take","Subproblem","Or'_to'_List"])); + +val screxpr = ref (distinct (remove op = "" + ["Let","If","Repeat","While","Try","Or"])); + +val listfuns = ref [(*_all_ functions in Isa99.List.thy *) + "@","filter","concat","foldl","hd","last","set","list_all", + "map","mem","nth","list_update","take","drop", + "takeWhile","dropWhile","tl","butlast", + "rev","zip","upt","remdups","nodups","replicate", + + "Cons","Nil"]; + +val scrfuns = ref (distinct (remove op = "" + ["Testvar"])); + +val listexpr = ref (union op = (!listfuns) (!scrfuns)); + +val notsimp = ref + (distinct (remove op = "" + (!tacs @ !screxpr @ (*!subpbls @*) !scrfuns @ !listfuns))); + +val negotiable = ref ((!tacs (*@ !subpbls*))); + +val tacpbl = ref + (distinct (remove op = "" (!tacs (*@ !subpbls*)))); +(*--^^^----- SHIFT? or delete ?*) + +*} + +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/Tools.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/Tools.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,113 @@ +(* = Tools.ML + +++ outcommented tests *) + + +fun eval_var (thmid:string) (op_:string) + (t as (Const(op0,t0) $ arg)) thy = + let + val t' = ((list2isalist HOLogic.realT) o vars) t; + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg); + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end + | eval_var _ _ _ _ = raise GO_ON; +(* +> val t = (term_of o the o (parse thy)) "Var (A=a*(b::real))"; +> val op_ = "Var"; +> val eval_fn = the (assoc (!eval_list, op_)); +> get_pair op_ eval_fn t; +> val (t as (Const(op0,t0) $ arg)) = t; +> eval_fn op0 t; + +> val thmid = "#Var_"; +> val (SOME(thmId,t')) = eval_var thmid op0 t; +val it = SOME ("#Var_(A::real) = (a::real) * (b::real)",Const # $ (# $ #)) + : (string * term) option +> Syntax.string_of_term (thy2ctxt thy) t'; +val it = "Var ((A::real) = (a::real) * (b::real)) = [A, a, b]" : string +*) +fun eval_Length (thmid:string) (op_:string) + (t as (Const(op0,t0) $ arg)) thy = + let + val t' = ((term_of_num HOLogic.realT) o length o isalist2list) arg; + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg); + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end + | eval_Length _ _ _ _ = raise GO_ON; +(* +> val thmid = "#Length_"; val op_ = "Length"; +> val s = "Length [A = a * b, a // #2 = #2]"; +> val (t as (Const(op0,t0) $ arg)) = (term_of o the o (parse thy)) s; +> val (SOME (id,t')) = eval_Length thmid op_ t; +val id = "#Length_[A = a * b, a // #2 = #2]" : string +val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#)) +val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm +--------------------------------------------- +> val thmid = "#Length_"; val op_ = "Length"; +> val s = + "if #1 < Length [A = a * b, a // #2 = #2] \ + \then make_fun (R, [make, function], no_met) A a_ [A = a * b, a // #2 = #2]\ + \else hd [A = a * b, a // #2 = #2]"; + +> (cterm_of thy) t'; +> val t = (term_of o the o (parse thy)) s; +> val eval_fn = the (assoc (!eval_list, op_)); +> val (SOME(_,t')) = get_pair op_ eval_fn t; +val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#)) +val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm + +> val ct = (the o (parse thy)) s; +> val (SOME(_,thm)) = get_calculation thy (op_, eval_fn) ct; +val thm = "Length [A = a * b, a // #2 = #2] = #2" [[ Free ( #2, real) !!!]] +> rewrite_ thy tless_true e_rls false thm ct; +("if #1 < #2 + then make_fun (R, [make, function], no_met) + A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]", + []) : (cterm * cterm list) option +> val ct = (the o (parse thy)) s; +> rewrite_set_ thy e_rls false eval_script ct; +("if #1 < #2 + then make_fun (R, [make, function], no_met) + A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]", + []) : (cterm * cterm list) option +*) + +fun eval_Nth (thmid:string) (op_:string) (t as + (Const (op0,t0) $ t1 $ t2 )) thy = +(writeln"@@@ eval_Nth"; + if is_num t1 andalso is_list t2 + then + let + val t' = (nth (num_of_term t1) (isalist2list t2)) + handle _ => raise GO_ON; + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) t1)^ + "_"^(Syntax.string_of_term (thy2ctxt thy) t2)^ + " = "^(Syntax.string_of_term (thy2ctxt thy) t'); + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end + else raise GO_ON +) + | eval_Nth _ _ _ _ = raise GO_ON; +(* +> val thmid = "#Nth_"; val op_ = "Nth"; +> val s = "Nth #2 [A = a * b, a // #2 = #2]"; +> val t = (term_of o the o (parse thy)) s; +> eval_Nth thmid op_ t; + +> val eval_fn = the (assoc (!eval_list, op_)); +> val (SOME(id,t')) = get_pair op_ eval_fn t; +> (cterm_of thy) t'; +val it = "Nth #2 [A = a * b, a // #2 = #2] = (a // #2 = #2)" +*) + + +(*17.6.00: calc_list instead eval_list*) +eval_list:= overwritel (! eval_list, + [("Var",eval_var "#Var_"), + ("Length",eval_Length "#Length_"), + ("Nth",eval_Nth "#Nth_") + ]); +(*17.6.00: association list for calculate_, calculate*) +calc_list:= overwritel (! calc_list, + [ + ("Var" ,("Var",eval_var "#Var_")), + ("Length",("Length",eval_Length "#Length_")), + ("Nth" ,("Nth",eval_Nth "#Nth_")) + ]); + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/Tools.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/Tools.thy Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,230 @@ +(* auxiliary functions used in scripts + author: Walther Neuper 000301 + WN0509 shift into Atools ?!? (because used also in where of models !) + + (c) copyright due to lincense terms. + +remove_thy"Tools"; +use_thy"ProgLang/Tools"; +*) + +theory Tools imports ListC begin + +(*belongs to theory ListC*) +ML {* +val first_isac_thy = @{theory ListC} +*} + +(*for Descript.thy*) + + (***********************************************************************) + (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*) + (***********************************************************************) +typedecl nam (* named variables *) +typedecl una (* unnamed variables *) +typedecl unl (* unnamed variables of type list, elementwise input prohibited*) +typedecl str (* structured variables *) +typedecl toreal (* var with undef real value: forces typing *) +typedecl toreall (* var with undef real list value: forces typing *) +typedecl tobooll (* var with undef bool list value: forces typing *) +typedecl unknow (* input without dsc in fmz=[] *) +typedecl cpy (* UNUSED: copy-named variables + identified by .._0, .._i .._' in pbt *) + (***********************************************************************) + (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*) + (***********************************************************************) + +consts + + UniversalList :: "bool list" + + lhs :: "bool => real" (*of an equality*) + rhs :: "bool => real" (*of an equality*) + Vars :: "'a => real list" (*get the variables of a term *) + matches :: "['a, 'a] => bool" + matchsub :: "['a, 'a] => bool" + +constdefs + + Testvar :: "[real, 'a] => bool" (*is a variable in a term: unused 6.5.03*) + "Testvar v t == v mem (Vars t)" (*by rewriting only,no Calcunused 6.5.03*) + +ML {* (*the former Tools.ML*) +(* auxiliary functions for scripts WN.9.00*) +(*11.02: for equation solving only*) +val UniversalList = (term_of o the o (parse @{theory})) "UniversalList"; +val EmptyList = (term_of o the o (parse @{theory})) "[]::bool list"; + +(*+ for Or_to_List +*) +fun or2list (Const ("True",_)) = (writeln"### or2list True";UniversalList) + | or2list (Const ("False",_)) = (writeln"### or2list False";EmptyList) + | or2list (t as Const ("op =",_) $ _ $ _) = + (writeln"### or2list _ = _";list2isalist bool [t]) + | or2list ors = + (writeln"### or2list _ | _"; + let fun get ls (Const ("op |",_) $ o1 $ o2) = + case o2 of + Const ("op |",_) $ _ $ _ => get (ls @ [o1]) o2 + | _ => ls @ [o1, o2] + in (((list2isalist bool) o (get [])) ors) + handle _ => raise error ("or2list: no ORs= "^(term2str ors)) end + ); +(*>val t = HOLogic.true_const; +> val t' = or2list t; +> term2str t'; +"Atools.UniversalList" +> val t = HOLogic.false_const; +> val t' = or2list t; +> term2str t'; +"[]" +> val t=(term_of o the o (parse thy)) "x=3"; +> val t' = or2list t; +> term2str t'; +"[x = 3]" +> val t=(term_of o the o (parse thy))"(x=3) | (x=-3) | (x=0)"; +> val t' = or2list t; +> term2str t'; +"[x = #3, x = #-3, x = #0]" : string *) + + +(** evaluation on the meta-level **) + +(*. evaluate the predicate matches (match on whole term only) .*) +(*("matches",("Tools.matches",eval_matches "#matches_")):calc*) +fun eval_matches (thmid:string) "Tools.matches" + (t as Const ("Tools.matches",_) $ pat $ tst) thy = + if matches thy tst pat + then let val prop = Trueprop $ (mk_equality (t, true_as_term)) + in SOME (Syntax.string_of_term @{context} prop, prop) end + else let val prop = Trueprop $ (mk_equality (t, false_as_term)) + in SOME (Syntax.string_of_term @{context} prop, prop) end + | eval_matches _ _ _ _ = NONE; +(* +> val t = (term_of o the o (parse thy)) + "matches (?x = 0) (1 * x ^^^ 2 = 0)"; +> eval_matches "/thmid/" "/op_/" t thy; +val it = + SOME + ("matches (x = 0) (1 * x ^^^ 2 = 0) = False", + Const (#,#) $ (# $ # $ Const #)) : (string * term) option + +> val t = (term_of o the o (parse thy)) + "matches (?a = #0) (#1 * x ^^^ #2 = #0)"; +> eval_matches "/thmid/" "/op_/" t thy; +val it = + SOME + ("matches (?a = #0) (#1 * x ^^^ #2 = #0) = True", + Const (#,#) $ (# $ # $ Const #)) : (string * term) option + +> val t = (term_of o the o (parse thy)) + "matches (?a * x = #0) (#1 * x ^^^ #2 = #0)"; +> eval_matches "/thmid/" "/op_/" t thy; +val it = + SOME + ("matches (?a * x = #0) (#1 * x ^^^ #2 = #0) = False", + Const (#,#) $ (# $ # $ Const #)) : (string * term) option + +> val t = (term_of o the o (parse thy)) + "matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0)"; +> eval_matches "/thmid/" "/op_/" t thy; +val it = + SOME + ("matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0) = True", + Const (#,#) $ (# $ # $ Const #)) : (string * term) option +----- before ?patterns ---: +> val t = (term_of o the o (parse thy)) + "matches (a * b^^^#2 = c) (#3 * x^^^#2 = #1)"; +> eval_matches "/thmid/" "/op_/" t thy; +SOME + ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2 = #1) = True", + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) + : (string * term) option + +> val t = (term_of o the o (parse thy)) + "matches (a * b^^^#2 = c) (#3 * x^^^#2222 = #1)"; +> eval_matches "/thmid/" "/op_/" t thy; +SOME ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2222 = #1) = False", + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) + +> val t = (term_of o the o (parse thy)) + "matches (a = b) (x + #1 + #-1 * #2 = #0)"; +> eval_matches "/thmid/" "/op_/" t thy; +SOME ("matches (a = b) (x + #1 + #-1 * #2 = #0) = True",Const # $ (# $ #)) +*) + +(*.does a pattern match some subterm ?.*) +fun matchsub thy t pat = + let fun matchs (t as Const _) = matches thy t pat + | matchs (t as Free _) = matches thy t pat + | matchs (t as Var _) = matches thy t pat + | matchs (Bound _) = false + | matchs (t as Abs (_, _, body)) = + if matches thy t pat then true else matches thy body pat + | matchs (t as f1 $ f2) = + if matches thy t pat then true + else if matchs f1 then true else matchs f2 + in matchs t end; + +(*("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")):calc*) +fun eval_matchsub (thmid:string) "Tools.matchsub" + (t as Const ("Tools.matchsub",_) $ pat $ tst) thy = + if matchsub thy tst pat + then let val prop = Trueprop $ (mk_equality (t, true_as_term)) + in SOME (Syntax.string_of_term @{context} prop, prop) end + else let val prop = Trueprop $ (mk_equality (t, false_as_term)) + in SOME (Syntax.string_of_term @{context} prop, prop) end + | eval_matchsub _ _ _ _ = NONE; + +(*get the variables in an isabelle-term*) +(*("Vars" ,("Tools.Vars" ,eval_var "#Vars_")):calc*) +fun eval_var (thmid:string) "Tools.Vars" + (t as (Const(op0,t0) $ arg)) thy = + let + val t' = ((list2isalist HOLogic.realT) o vars) t; + val thmId = thmid^(Syntax.string_of_term @{context} arg); + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end + | eval_var _ _ _ _ = NONE; + +fun lhs (Const ("op =",_) $ l $ _) = l + | lhs t = error("lhs called with (" ^ term2str t ^ ")"); +(*("lhs" ,("Tools.lhs" ,eval_lhs "")):calc*) +fun eval_lhs _ "Tools.lhs" + (t as (Const ("Tools.lhs",_) $ (Const ("op =",_) $ l $ _))) _ = + SOME ((term2str t) ^ " = " ^ (term2str l), + Trueprop $ (mk_equality (t, l))) + | eval_lhs _ _ _ _ = NONE; +(* +> val t = (term_of o the o (parse thy)) "lhs (1 * x ^^^ 2 = 0)"; +> val SOME (id,t') = eval_lhs 0 0 t 0; +val id = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string +> term2str t'; +val it = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string +*) + +fun rhs (Const ("op =",_) $ _ $ r) = r + | rhs t = error("rhs called with (" ^ term2str t ^ ")"); +(*("rhs" ,("Tools.rhs" ,eval_rhs "")):calc*) +fun eval_rhs _ "Tools.rhs" + (t as (Const ("Tools.rhs",_) $ (Const ("op =",_) $ _ $ r))) _ = + SOME ((term2str t) ^ " = " ^ (term2str r), + Trueprop $ (mk_equality (t, r))) + | eval_rhs _ _ _ _ = NONE; + + +(*for evaluating scripts*) + +val list_rls = append_rls "list_rls" list_rls + [Calc ("Tools.rhs",eval_rhs "")]; +ruleset' := overwritelthy @{theory} (!ruleset', + [("list_rls",list_rls) + ]); +calclist':= overwritel (!calclist', + [("matches",("Tools.matches",eval_matches "#matches_")), + ("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")), + ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")), + ("lhs" ,("Tools.lhs" ,eval_lhs "")), + ("rhs" ,("Tools.rhs" ,eval_rhs "")) + ]); + +*} +end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/calculate.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/calculate.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,408 @@ +(* calculate values for function constants + (c) Walther Neuper 000106 + +use"ProgLang/calculate.sml"; +*) + + +(* dirty type-conversion 30.1.00 for "fixed_values [R=R]" *) + +val aT = Type ("'a", []); +(* isas types for Free, parseold: (1) "R=R" or (2) "R=(R::real)": +(1) +> val (TFree(ss2,TT2)) = T2; +val ss2 = "'a" : string +val TT2 = ["term"] : sort +(2) +> val (Type(ss2',TT2')) = T2'; +val ss2' = "RealDef.real" : string +val TT2' = [] : typ list +(3) +val realType = TFree ("RealDef.real", HOLogic.termS); +is different internally, too; + +(1) .. (3) are displayed equally !!! +*) + + + +(* 30.1.00: generating special terms for ME: + (1) binary numerals reconverted to Free ("#num",...) + by libarary_G.num_str: called from parse (below) and + interface_ME_ISA for all thms used + (compare HOLogic.dest_binum) + (2) 'a types converted to RealDef.real by typ_a2real + in parse below + (3) binary operators fixed to type real in RatArith.thy + (trick by Markus Wenzel) +*) + + + + +(** calculate numerals **) + +(*27.3.00: problems with patterns below: +"Vars (a // #2 = r * xxxxx b)" doesn't work, but +"Vars (a // #2 = r * sqrt b)" works +*) + +fun popt2str (SOME (str, term)) = "SOME "^term2str term + | popt2str NONE = "NONE"; + +(* scan a term for applying eval_fn ef +args + thy: + op_: operator (as string) selecting the root of the pair + ef : fn : (string -> term -> theory -> (string * term) option) + ^^^^^^... for creating the string for the resulting theorem + t : term to be scanned +result: + (string * term) option: found by the eval_* -function of type + fn : string -> string -> term -> theory -> (string * term) option + ^^^^^^... the selecting operator op_ (variable for eval_binop) +*) +fun get_pair thy op_ (ef:string -> term -> theory -> (string * term) option) + (t as (Const(op0,t0) $ arg)) = (* unary fns *) +(* val (thy, op_, (ef), (t as (Const(op0,t0) $ arg))) = + (thy, op_, eval_fn, ct); + *) + if op_ = op0 then + let val popt = ef op_ t thy + in case popt of + SOME _ => popt + | NONE => get_pair thy op_ ef arg end + else get_pair thy op_ ef arg + + | get_pair thy "Atools.ident" ef (t as (Const("Atools.ident",t0) $ _ $ _ )) = +(* val (thy, "Atools.ident", ef, t as (Const(op0,_) $ t1 $ t2)) = + (thy, op_, eval_fn, ct); + *) + ef "Atools.ident" t thy (* not nested *) + + | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2)) = (* binary funs*) +(* val (thy, op_, ef, (t as (Const(op0,_) $ t1 $ t2))) = + (thy, op_, eval_fn, ct); + *) + ((*writeln("1.. get_pair: binop = "^op_);*) + if op_ = op0 then + let val popt = ef op_ t thy + (*val _ = writeln("2.. get_pair: "^term2str t^" -> "^popt2str popt)*) + in case popt of + SOME (id,_) => popt + | NONE => + let val popt = get_pair thy op_ ef t1 + (*val _ = writeln("3.. get_pair: "^term2str t1^ + " -> "^popt2str popt)*) + in case popt of + SOME (id,_) => popt + | NONE => get_pair thy op_ ef t2 + end + end + else (*search subterms*) + let val popt = get_pair thy op_ ef t1 + (*val _ = writeln("4.. get_pair: "^term2str t^" -> "^popt2str popt)*) + in case popt of + SOME (id,_) => popt + | NONE => get_pair thy op_ ef t2 + end) + | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2 $ t3)) =(* trinary funs*) + ((*writeln("### get_pair 4a: t= "^term2str t); + writeln("### get_pair 4a: op_= "^op_); + writeln("### get_pair 4a: op0= "^op0);*) + if op_ = op0 then + case ef op_ t thy of + SOME tt => SOME tt + | NONE => (case get_pair thy op_ ef t2 of + SOME tt => SOME tt + | NONE => get_pair thy op_ ef t3) + else (case get_pair thy op_ ef t1 of + SOME tt => SOME tt + | NONE => (case get_pair thy op_ ef t2 of + SOME tt => SOME tt + | NONE => get_pair thy op_ ef t3))) + | get_pair thy op_ ef (Const _) = NONE + | get_pair thy op_ ef (Free _) = NONE + | get_pair thy op_ ef (Var _) = NONE + | get_pair thy op_ ef (Bound _) = NONE + | get_pair thy op_ ef (Abs(a,T,body)) = get_pair thy op_ ef body + | get_pair thy op_ ef (t1$t2) = + let(*val _= writeln("5.. get_pair t1 $ t2: "^term2str t1^" + $ "^term2str t2)*) + val popt = get_pair thy op_ ef t1 + in case popt of + SOME _ => popt + | NONE => ((*writeln"### get_pair: t1 $ t2 -> NONE";*) + get_pair thy op_ ef t2) + end; + (* +> val t = (term_of o the o (parse thy)) "#3 + #4"; +> val eval_fn = the (assoc (!eval_list, "op +")); +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> atomty t'; +> +> val t = (term_of o the o (parse thy)) "(a + #3) + #4"; +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "#3 + (#4 + (a::real))"; +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "x = #5 * (#3 + (#4 + a))"; +> atomty t; +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> val it = "#3 + (#4 + a) = #7 + a" : string +> +> +> val t = (term_of o the o (parse thy)) "#-4//#-2"; +> val eval_fn = the (assoc (!eval_list, "cancel")); +> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "#2^^^#3"; +> eval_binop "xxx" "pow" t thy; +> val eval_fn = (eval_binop "xxx") +> : string -> term -> theory -> (string * term) option; +> val SOME (id,t') = get_pair thy "pow" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> val eval_fn = the (assoc (!eval_list, "pow")); +> val (SOME (id,t')) = get_pair thy "pow" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4"; +> val eval_fn = the (assoc (!eval_list, "op *")); +> val (SOME (id,t')) = get_pair thy "op *" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "#0 < #4"; +> val eval_fn = the (assoc (!eval_list, "op <")); +> val (SOME (id,t')) = get_pair thy "op <" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> val t = (term_of o the o (parse thy)) "#0 < #-4"; +> val (SOME (id,t')) = get_pair thy "op <" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "#3 is_const"; +> val eval_fn = the (assoc (!eval_list, "is'_const")); +> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> val t = (term_of o the o (parse thy)) "a is_const"; +> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "#6//(#8::real)"; +> val eval_fn = the (assoc (!eval_list, "cancel")); +> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "sqrt #12"; +> val eval_fn = the (assoc (!eval_list, "SqRoot.sqrt")); +> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> val it = "sqrt #12 = #2 * sqrt #3 " : string +> +> val t = (term_of o the o (parse thy)) "sqrt #9"; +> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +> +> val t = (term_of o the o (parse thy)) "Nth #2 [#11,#22,#33]"; +> val eval_fn = the (assoc (!eval_list, "Tools.Nth")); +> val (SOME (id,t')) = get_pair thy "Tools.Nth" eval_fn t; +> Syntax.string_of_term (thy2ctxt thy) t'; +*) + +(* val ((op_, eval_fn),ct)=(cc,pre); + (get_calculation_ Isac.thy (op_, eval_fn) ct) handle e => print_exn e; + parse thy "" + *) +(*.get a thm from an op_ somewhere in the term; + apply ONLY to (uminus_to_string term), uminus_to_string (- 4711) --> (-4711).*) +fun get_calculation_ thy (op_, eval_fn) ct = +(* val (thy, (op_, eval_fn), ct) = + (thy, (the (assoc(!calclist',"order_system"))), t); + *) + case get_pair thy op_ eval_fn ct of + NONE => ((*writeln("@@@ get_calculation: NONE, op_="^op_); + writeln("@@@ get_calculation: ct= ");atomty ct;*) + NONE) + | SOME (thmid,t) => + ((*writeln("@@@ get_calculation: NONE, op_="^op_); + writeln("@@@ get_calculation: ct= ");atomty ct;*) + SOME (thmid, (make_thm o (cterm_of thy)) t)); +(* +> val ct = (the o (parse thy)) "#9 is_const"; +> get_calculation_ thy ("is'_const",the (assoc(!eval_list,"is'_const"))) ct; +val it = SOME ("is_const9_","(is_const 9 ) = True [(is_const 9 ) = True]") + +> val ct = (the o (parse thy)) "sqrt #9"; +> get_calculation_ thy ("sqrt",the (assoc(!eval_list,"sqrt"))) ct; +val it = SOME ("sqrt_9_","sqrt 9 = 3 [sqrt 9 = 3]") : (string * thm) option + +> val ct = (the o (parse thy)) "#4<#4"; +> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;fun is_no str = (hd o explode) str = "#"; + +val it = SOME ("less_5_4","(5 < 4) = False [(5 < 4) = False]") + +> val ct = (the o (parse thy)) "a<#4"; +> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct; +val it = NONE : (string * thm) option + +> val ct = (the o (parse thy)) "#5<=#4"; +> get_calculation_ thy ("op <=",the (assoc(!eval_list,"op <="))) ct; +val it = SOME ("less_equal_5_4","(5 <= 4) = False [(5 <= 4) = False]") + +-------------------------------------------------------------------6.8.02: + val thy = SqRoot.thy; + val t = (term_of o the o (parse thy)) "1+2"; + get_calculation_ thy (the(assoc(!calc_list,"PLUS"))) t; + val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option +-------------------------------------------------------------------6.8.02: + val t = (term_of o the o (parse thy)) "-1"; + atomty t; + val t = (term_of o the o (parse thy)) "0"; + atomty t; + val t = (term_of o the o (parse thy)) "1"; + atomty t; + val t = (term_of o the o (parse thy)) "2"; + atomty t; + val t = (term_of o the o (parse thy)) "999999999"; + atomty t; +-------------------------------------------------------------------6.8.02: + +> val ct = (the o (parse thy)) "a+#3+#4"; +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; +val it = SOME ("add_3_4","a + 3 + 4 = a + 7 [a + 3 + 4 = a + 7]") + +> val ct = (the o (parse thy)) "#3+(#4+a)"; +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; +val it = SOME ("add_3_4","3 + (4 + a) = 7 + a [3 + (4 + a) = 7 + a]") + +> val ct = (the o (parse thy)) "a+(#3+#4)+#5"; +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; +val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option + +> val ct = (the o (parse thy)) "#3*(#4*a)"; +> get_calculation_ thy ("op *",the (assoc(!eval_list,"op *"))) ct; +val it = SOME ("mult_3_4","3 * (4 * a) = 12 * a [3 * (4 * a) = 12 * a]") + +> val ct = (the o (parse thy)) "#3 + #4^^^#2 + #5"; +> get_calculation_ thy ("pow",the (assoc(!eval_list,"pow"))) ct; +val it = SOME ("4_(+2)","4 ^ 2 = 16 [4 ^ 2 = 16]") : (string * thm) option + +> val ct = (the o (parse thy)) "#-4//#-2"; +> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct; +val it = SOME ("cancel_(-4)_(-2)","(-4) // (-2) = (+2) [(-4) // (-2) = (+2)]") + +> val ct = (the o (parse thy)) "#6//#-8"; +> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct; +val it = SOME ("cancel_6_(-8)","6 // (-8) = (-3) // 4 [6 // (-8) = (-3) // 4]") + +*) + + +(* +> val ct = (the o (parse thy)) "a + 3*4"; +> applicable "calculate" (Calc("op *", "mult_")) ct; +val it = SOME "3 * 4 = 12 [3 * 4 = 12]" : thm option + +-------------------------- +> val ct = (the o (parse thy)) "3 =!= 3"; +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); +val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm + +> val ct = (the o (parse thy)) "~ (3 =!= 3)"; +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); +val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm + +> val ct = (the o (parse thy)) "3 =!= 4"; +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); +val thm = "(3 =!= 4) = False [(3 =!= 4) = False]" : thm + +> val ct = (the o (parse thy)) "( 4 + (4 * x + x ^ 2) =!= (+0))"; +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); + "(4 + (4 * x + x ^ 2) =!= (+0)) = False" + +> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))"; +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); + "(4 + (4 * x + x ^ 2) =!= (+0)) = False" + +> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))"; +> val rls = eval_rls; +> val (ct,_) = the (rewrite_set_ thy false rls ct); +val ct = "True" : cterm +-------------------------- +*) + + +(*.get a thm applying an op_ to a term; + apply ONLY to (numbers_to_string term), numbers_to_string (- 4711) --> (-4711).*) +(* val (thy, (op_, eval_fn), ct) = + (thy, ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_"), term); + *) +fun get_calculation1_ thy ((op_, eval_fn):cal) ct = + case eval_fn op_ ct thy of + NONE => NONE + | SOME (thmid,t) => + SOME (thmid, (make_thm o (cterm_of thy)) t); + + + + + +(*.substitute bdv in an rls and leave Calc as they are.(*28.10.02*) +fun inst_thm' subs (Thm (id, thm)) = + Thm (id, (*read_instantiate throws: *** No such variable in term: ?bdv*) + (read_instantiate subs thm) handle _ => thm) + | inst_thm' _ calc = calc; +fun inst_thm' (subs as (bdv,_)::_) (Thm (id, thm)) = + Thm (id, (writeln("@@@ inst_thm': thm= "^(string_of_thmI thm)); + if bdv mem (vars_str o #prop o rep_thm) thm + then (writeln("@@@ inst_thm': read_instantiate, thm="^((string_of_thmI thm))); + read_instantiate subs thm) + else (writeln("@@@ inst_thm': not mem.. "^bdv); + thm))) + | inst_thm' _ calc = calc; + +fun instantiate_rls subs + (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca, + asm_thm=at,rules=rules,scr=scr}:rls) = + (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca, + asm_thm=at,scr=scr, + rules = map (inst_thm' subs) rules}:rls);---------------------------*) + + + +(** rewriting: ordered, conditional **) + +fun mk_rule (prems,l,r) = + Trueprop $ (list_implies (prems, mk_equality (l,r))); + +(* 'norms' a rule, e.g. +(*1*) a = 1 ==> a*(b+c) = b+c + => a = 1 ==> a*(b+c) = b+c no change +(*2*) t = t => (t=t) = True !! +(*3*) [| k < l; m + l = k + n |] ==> m < n + => [| k m < n = True !! *) +(* val it = fn : term -> term *) +fun norm rule = + let + val (prems,concl)=(map strip_trueprop(Logic.strip_imp_prems rule), + (strip_trueprop o Logic.strip_imp_concl)rule) + in if is_equality concl then + let val (l,r) = dest_equals' concl + in if l = r then + (*2*) mk_rule(prems,concl,true_as_term) + else (*1*) rule end + else (*3*) mk_rule(prems,concl,true_as_term) + end; + + + + + + + + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/rewrite.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/rewrite.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,736 @@ +(* isac's rewriter + (c) Walther Neuper 2000 + +use"ProgLang/rewrite.sml"; +use"rewrite.sml"; +*) + + +exception NO_REWRITE; +exception STOP_REW_SUB; (*WN050820 quick and dirty*) + +(*17.6.00: rewrite by going down the term with rew_sub*) +(* val (thy, i, bdv, tless, rls, put_asm, thm, ct) = + (thy, 1, []:(Term.term * Term.term) list, rew_ord, erls, bool,thm,term); + *) +fun rewrite__ thy i bdv tless rls put_asm thm ct = + ((*writeln ("@@@ r..te__ begin: t = "^(term2str ct));*) + let + val (t',asms,lrd,rew) = + rew_sub thy i bdv tless rls put_asm [(*root of the term*)] + (((inst_bdv bdv) o norm o #prop o rep_thm) thm) ct; + in if rew then SOME (t', distinct asms) + else NONE end) +(* val(r,t)=(((inst_bdv bdv) o norm o #prop o rep_thm) thm,ct); + val t1 = (#prop o rep_thm) thm; + val t2 = norm t1; + val t3 = inst_bdv bdv t2; + + val thm4 = read_instantiate [("bdv","x")] thm; + val t4 = (norm o #prop o rep_thm) thm4; + *) +(* val (thy, i, bdv, tless, rls, put_asm, r, t) = + (thy, i,bdv, tless, rls, put_asm, + (((inst_bdv bdv) o norm o #prop o rep_thm) thm), ct); + val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) = + (thy, 1, [], ord, erls,false, [], r, t); + val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) = + (thy, i, bdv, tless, rls, put_asm, [], + ((inst_bdv bdv) o norm o #prop o rep_thm) thm, ct); + *) +and rew_sub thy i bdv tless rls put_asm lrd r t = + ((*writeln ("@@@ rew_sub begin: t = "^(term2str t));*) + let (* copy from Pure/thm.ML: fun rewritec *) + (*val (lhs,rhs) = (dest_equals' o strip_trueprop + o Logic.strip_imp_concl) r; + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs,t); + val r' = ren_inst (insts, r, lhs, t); + val p' = map strip_trueprop (Logic.strip_imp_prems r'); + val t' = (snd o dest_equals' o strip_trueprop + o Logic.strip_imp_concl) r';*) + val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop + o Logic.strip_imp_concl) r; + val r' = Envir.subst_term (Pattern.match thy (lhs, t) + (Vartab.empty, Vartab.empty)) r; + val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r'); + val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop + o Logic.strip_imp_concl) r'; + (*val _= writeln("@@@ rew_sub match: t'= "^(term2str t'));*) + val _= if ! trace_rewrite andalso i < ! depth andalso p' <> [] + then writeln((idt"#"(i+1))^" eval asms: "^(term2str r')) else(); + val (t'',p'') = (*conditional rewriting*) + let val (simpl_p', nofalse) = eval__true thy (i+1) p' bdv rls + in if nofalse + then (if ! trace_rewrite andalso i < ! depth andalso p' <> [] + then writeln((idt"#"(i+1))^" asms accepted: "^(terms2str p')^ + " stored: "^(terms2str simpl_p')) + else(); (t',simpl_p')) (* + uncond.rew. *) + else + (if ! trace_rewrite andalso i < ! depth + then writeln((idt"#"(i+1))^" asms false: "^(terms2str p')) + else(); raise STOP_REW_SUB (*dont go into subterms of cond*)) + end + in if perm lhs rhs andalso not (tless bdv (t',t)) (*ordered rewriting*) + then (if ! trace_rewrite andalso i < ! depth + then writeln((idt"#"i)^" not: \""^ + (term2str t)^"\" > \""^ + (term2str t')^"\"") else (); + raise NO_REWRITE ) + else ((*writeln("##@ rew_sub: (t''= "^(term2str t'')^ + ", p'' ="^(terms2str p'')^", true)");*) + (t'',p'',[],true)) + end + ) handle _ (*NO_REWRITE WN050820 causes diff.behav. in tests + MATCH!*) => + ((*writeln ("@@@ rew_sub gosub: t = "^(term2str t));*) + case t of + Const(s,T) => (Const(s,T),[],lrd,false) + | Free(s,T) => (Free(s,T),[],lrd,false) + | Var(n,T) => (Var(n,T),[],lrd,false) + | Bound i => (Bound i,[],lrd,false) + | Abs(s,T,body) => + let val (t', asms, lrd, rew) = + rew_sub thy i bdv tless rls put_asm (lrd@[D]) r body + in (Abs(s,T,t'), asms, [], rew) end + | t1 $ t2 => + let val (t2', asm2, lrd, rew2) = + rew_sub thy i bdv tless rls put_asm (lrd@[R]) r t2 + in if rew2 then (t1 $ t2', asm2, lrd, true) + else let val (t1', asm1, lrd, rew1) = + rew_sub thy i bdv tless rls put_asm (lrd@[L]) r t1 + in if rew1 then (t1' $ t2, asm1, lrd, true) + else (t1 $ t2,[], lrd, false) end + end) +(* val (cprems',rls)=([pre],prls); + rewrite__set_ thy i false rls pre; + *) +and eval__true thy i asms bdv rls = +(* val (thy, i, asms, bdv, rls) = (thy, (i+1), p', bdv, rls); + *) + if asms = [HOLogic.true_const] orelse asms = [] + then ([], true) else if asms = [HOLogic.false_const] then ([], false) + else let + fun chk indets [] = (indets, true)(*return asms<>True until false*) + | chk indets (a::asms) = +(* val (indets, (a::asms)) = ([], asms); + *) + (case rewrite__set_ thy (i+1) false bdv rls a of + NONE => (chk (indets @ [a]) asms) + | SOME (t, a') => + if t = HOLogic.true_const + then (chk (indets @ a') asms) + else if t = HOLogic.false_const then ([], false) + (*asm false .. thm not applied ^^^; continue until False vvv*) + else (chk (indets @ [t] @ a') asms)); + in chk [] asms end + +and rewrite__set_ _ _ __ Erls t = + raise error("rewrite__set_ called with 'Erls' for '"^term2str t^"'") + | rewrite__set_ thy i _ _ (rrls as Rrls _) t = + let val _= if ! trace_rewrite andalso i < ! depth + then writeln ((idt"#"i)^" rls: "^(id_rls rrls)^" on: "^ + (term2str t)) else () + val (t', asm, rew) = app_rev thy (i+1) rrls t + in if rew then SOME (t', distinct asm) + else NONE end + | rewrite__set_ thy i put_asm bdv rls ct = +(* val (thy, i, put_asm, bdv, rls, ct) = (thy, 1, bool, [], rls, term); + *) + let + datatype switch = Appl | Noap; + fun rew_once ruls asm ct Noap [] = (ct,asm) + | rew_once ruls asm ct Appl [] = + (case rls of Rls _ => rew_once ruls asm ct Noap ruls + | Seq _ => (ct,asm)) + | rew_once ruls asm ct apno (rul::thms) = +(* val (ruls, asm, ct, apno, (rul::thms)) = (ruls, [], ct, Noap, ruls); + val Thm (thmid, thm) = rul; + *) + case rul of + Thm (thmid, thm) => + (if !trace_rewrite andalso i < ! depth + then writeln((idt"#"(i+1))^" try thm: "^thmid) else (); + case rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) + ((#erls o rep_rls) rls) put_asm thm ct of + NONE => rew_once ruls asm ct apno thms + | SOME (ct',asm') => (if ! trace_rewrite andalso i < ! depth + then writeln((idt"="(i+1))^" rewrites to: "^ + (term2str ct')) else (); + rew_once ruls (union (op =) asm asm') ct' Appl (rul::thms))) + | Calc (cc as (op_,_)) => + (let val _= if !trace_rewrite andalso i < ! depth then + writeln((idt"#"(i+1))^" try calc: "^op_^"'") else (); + val ct = uminus_to_string ct + in case get_calculation_ thy cc ct of + NONE => ((*writeln "@@@ rewrite__set_: get_calculation_-> NONE";*) + rew_once ruls asm ct apno thms) + | SOME (thmid, thm') => + let + val pairopt = + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) + ((#erls o rep_rls) rls) put_asm thm' ct; + val _ = if pairopt <> NONE then () + else raise error("rewrite_set_, rewrite_ \""^ + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") + val _ = if ! trace_rewrite andalso i < ! depth + then writeln((idt"="(i+1))^" calc. to: "^ + (term2str ((fst o the) pairopt))) + else() + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end + end) +(* use"ProgLang/rewrite.sml"; + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) + | Cal1 (cc as (op_,_)) => + (let val _= if !trace_rewrite andalso i < ! depth then + writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else (); + val ct = uminus_to_string ct + in case get_calculation1_ thy cc ct of + NONE => (ct, asm) + | SOME (thmid, thm') => + let + val pairopt = + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) + ((#erls o rep_rls) rls) put_asm thm' ct; + val _ = if pairopt <> NONE then () + else raise error("rewrite_set_, rewrite_ \""^ + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") + val _ = if ! trace_rewrite andalso i < ! depth + then writeln((idt"="(i+1))^" cal1. to: "^ + (term2str ((fst o the) pairopt))) + else() + in the pairopt end + end) +(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) + | Rls_ rls' => + (case rewrite__set_ thy (i+1) put_asm bdv rls' ct of + SOME (t',asm') => rew_once ruls (union (op =) asm asm') t' Appl thms + | NONE => rew_once ruls asm ct apno thms); + + val ruls = (#rules o rep_rls) rls; + val _= if ! trace_rewrite andalso i < ! depth + then writeln ((idt"#"i)^" rls: "^(id_rls rls)^" on: "^ + (term2str ct)) else () + val (ct',asm') = rew_once ruls [] ct Noap ruls; + in if ct = ct' then NONE else SOME (ct', distinct asm') end + +and app_rev thy i rrls t = + let (*.check a (precond, pattern) of a rev-set; stops with 1st true.*) + fun chk_prepat thy erls [] t = true + | chk_prepat thy erls prepat t = + let fun chk (pres, pat) = + (let val subst: Type.tyenv * Envir.tenv = + Pattern.match thy (pat, t) + (Vartab.empty, Vartab.empty) + in snd (eval__true thy (i+1) + (map (Envir.subst_term subst) pres) + [] erls) + end) + handle _ => false + fun scan_ f [] = false (*scan_ NEVER called by []*) + | scan_ f (pp::pps) = if f pp then true + else scan_ f pps; + in scan_ chk prepat end; + + (*.apply the normal_form of a rev-set.*) + fun app_rev' thy (Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}) t = + if chk_prepat thy erls prepat t + then ((*writeln("### app_rev': t = "^(term2str t));*) + normal_form t) + else NONE; + + val opt = app_rev' thy rrls t + in case opt of + SOME (t', asm) => (t', asm, true) + | NONE => app_sub thy i rrls t + end +and app_sub thy i rrls t = + ((*writeln("### app_sub: subterm = "^(term2str t));*) + case t of + Const (s, T) => (Const(s, T), [], false) + | Free (s, T) => (Free(s, T), [], false) + | Var (n, T) => (Var(n, T), [], false) + | Bound i => (Bound i, [], false) + | Abs (s, T, body) => + let val (t', asm, rew) = app_rev thy i rrls body + in (Abs(s, T, t'), asm, rew) end + | t1 $ t2 => + let val (t2', asm2, rew2) = app_rev thy i rrls t2 + in if rew2 then (t1 $ t2', asm2, true) + else let val (t1', asm1, rew1) = app_rev thy i rrls t1 + in if rew1 then (t1' $ t2, asm1, true) + else (t1 $ t2, [], false) end + end); + + + +(*.rewriting without argument [] for rew_ord.*) +(*WN.11.6.03: shouldnt asm<>[] lead to false ????*) +fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls; + + +(*.rewriting without internal argument [] for rew_ord.*) +(* val (thy, rew_ord, erls, bool, thm, term) = + (thy, (assoc_rew_ord ro), rls', false, (assoc_thm' thy thm'), f); + val (thy, rew_ord, erls, bool, thm, term) = + (thy, rew_ord, erls, false, thm, t''); + *) +fun rewrite_ thy rew_ord erls bool thm term = + rewrite__ thy 1 [] rew_ord erls bool thm term; +fun rewrite_set_ thy bool rls term = +(* val (thy, bool, rls, term) = (thy, false, srls, t); + *) + rewrite__set_ thy 1 bool [] rls term; + + +fun subs'2subst thy (s:subs') = + (((map (apfst (term_of o the o (parse thy)))) + o (map (apsnd (term_of o the o (parse thy))))) s):subst; + +(*.variants of rewrite.*) +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, + thus the argument put_asm IS NOT NECESSARY -- FIXME*) +(* val (rew_ord,rls,put_asm,thm,ct)= + (e_rew_ord,poly_erls,false,num_str d1_isolate_add2,t); + *) +fun rewrite_inst_ (thy:theory) rew_ord (rls:rls) (put_asm:bool) + (subst:(term * term) list) (thm:thm) (ct:term) = + rewrite__ thy 1 subst rew_ord rls put_asm thm ct; + +fun rewrite_set_inst_ (thy:theory) + (put_asm:bool) (subst:(term * term) list) (rls:rls) (ct:term) = + (*let + val subst = subs'2subst thy subs'; + val subrls = instantiate_rls subs' rls + in*) rewrite__set_ thy 1 put_asm subst (*sub*)rls ct + (*end*); + +(* val (thy, ord, erls, subte, t) = (thy, dummy_ord, Erls, subte, t); + *) +(*.rewrite using a list of terms.*) +fun rewrite_terms_ thy ord erls subte t = + let (*val _=writeln("### rewrite_terms_ subte= '"^terms2str subte^"' ..."^ + term_detail2str (hd subte)^ + "### rewrite_terms_ t= '"^term2str t^"' ..."^ + term_detail2str t);*) + fun rew_ (t', asm') [] _ = (t', asm') + (* 1st val (t', asm', rules as r::rs, t) = (e_term, [], subte, t); + 2nd val (t', asm', rules as r::rs, t) = (t'', [], rules, t''); + rew_ (t', asm') (r::rs) t; + *) + | rew_ (t', asm') (rules as r::rs) t = + let val _ = writeln("rew_ "^term2str t); + val (t'', asm'', lrd, rew) = + rew_sub thy 1 [] ord erls false [] r t + in if rew + then (writeln("true rew_ "^term2str t''); + rew_ (t'', asm' @ asm'') rules t'') + else (writeln("false rew_ "^term2str t''); + rew_ (t', asm') rs t') + end + val (t'', asm'') = rew_ (e_term, []) subte t + in if t'' = e_term + then NONE else SOME (t'', asm'') + end; + + +(*. search ct for adjacent numerals and calculate them by operator isa_fn .*) +fun calculate_ thy isa_fn ct = + let val ct = uminus_to_string ct + in case get_calculation_ thy isa_fn ct of + NONE => NONE + | SOME (thmID, thm) => + (let val SOME (rew,_) = rewrite_ thy dummy_ord e_rls false thm ct + in SOME (rew,(thmID, thm)) end) + handle _ => error ("calculate_: "^thmID^" does not rewrite") + end; +(* +> val thy = InsSort.thy; +> val op_ = "le"; (* < *) +> val ct = (the o (parse thy)) + "foldr ins [#2] (if #1 < #3 then #1 # ins [] #3 else [#3, #1])"; +> calculate_ thy op_ ct; + SOME + ("foldr ins [#2] (if True then #1 # ins [] #3 else [#3, #1])", + "(#1 < #3) = True") : (cterm * thm) option *) + + +(* for test-printouts: +val _ = writeln("in rew_sub : "^( Syntax.string_of_term (thy2ctxt thy) t)) +val _ = writeln("in eval_true: prems= "^(commas (map (Syntax.string_of_term (thy2ctxt thy)) prems'))) +*) + + + + + + +fun get_rls_scr rs' = ((#scr o rep_rls o #2 o the o assoc') (!ruleset',rs')) + handle _ => raise error ("get_rls_scr: no script for "^rs'); + + +(*make_thm added to Pure/thm.ML*) +fun mk_thm thy str = + let val t = (term_of o the o (parse thy)) str + val t' = case t of + Const ("==>",_) $ _ $ _ => t + | _ => Trueprop $ t + in make_thm (cterm_of thy t') end; +(* + val str = "?r ^^^ 2 = ?r * ?r"; + val thm = realpow_twoI; + + val t1 = (#prop o rep_thm) (num_str thm); + val t2 = Trueprop $ ((term_of o the o (parse thy)) str); + t1 = t2; +val it = true : bool ... !!! + val th1 = (num_str thm); + val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e; + th1 = th2; +ML> val it = false : bool ... HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?! + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + val str = "k ~= 0 ==> m * k / (n * k) = m / n"; + val thm = real_mult_div_cancel2; + + val t1 = (#prop o rep_thm) (num_str thm); + val t2 = ((term_of o the o (parse thy)) str); + t1 = t2; +val it = false : bool ... Var .. Free + val th1 = (num_str thm); + val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e; + th1 = th2; +ML> val it = false : bool ... PLUS HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?! +*) + + +(*prints subgoal etc. +((goal thy);(topthm()) o ) str; *) +(*assume rejects scheme variables + assume ((cterm_of thy) (Trueprop $ + (term_of o the o (parse thy)) str)); *) + + +(* outcommented 18.11.xx, xx < 02 ------- +fun rul2rul' (Thm (thmid, thm)) = Thm'(thmid, string_of_thmI thm) + | rul2rul' (Calc op_) = Calc' op_; +fun rul'2rul thy (Thm'(thmid, ct')) = + Thm (thmid, mk_thm thy ct') + | rul'2rul thy' (Calc' op_) = Calc op_; + + +fun rls2rls' (Rls{preconds=preconds,rew_ord=rew_ord,rules=rules}:rls) = + Rls'{preconds'= map string_of_cterm preconds, + rew_ord' = fst rew_ord, + rules' = map rul2rul' rules}:rlsdat'; + +fun rls'2rls thy' (Rls'{preconds'=preconds,rew_ord'=rew_ord, + rules'=rules}:rlsdat') = + let val thy = the (assoc' (theory',thy')) + in Rls{preconds = map (the o (parse thy)) preconds, + rew_ord = (rew_ord, the (assoc'(rew_ord',rew_ord))), + rules = map (rul'2rul thy) rules}:rls end; +------- *) + +(*.get the theorem associated with the xstring-identifier; + if the identifier starts with "sym_" then swap lhs = rhs around = + (ATTENTION: "RS sym" attaches a [.] -- remove it with string_of_thmI); + identifiers starting with "#" come from Calc and + get a hand-made theorem (containing numerals only).*) +fun assoc_thm' (thy:theory) ((thmid, ct'):thm') = + (case explode thmid of + "s"::"y"::"m"::"_"::id => + if hd id = "#" + then mk_thm thy ct' + else ((num_str o (PureThy.get_thm thy)) (implode id)) RS sym + | id => + if hd id = "#" + then mk_thm thy ct' + else (num_str o (PureThy.get_thm thy)) thmid + ) handle _ => + raise error ("assoc_thm': '"^thmid^"' not in '"^ + (theory2domID thy)^"' (and parents)"); +(*> assoc_thm' Isac.thy ("sym_#mult_2_3","6 = 2 * 3"); +val it = "6 = 2 * 3" : thm + +> assoc_thm' Isac.thy ("real_add_zero_left",""); +val it = "0 + ?z = ?z" : thm + +> assoc_thm' Isac.thy ("sym_real_add_zero_left",""); +val it = "?t = 0 + ?t" [.] : thm + +> assoc_thm' HOL.thy ("sym_real_add_zero_left",""); +*** Unknown theorem(s) "real_add_zero_left" +*** assoc_thm': 'sym_real_add_zero_left' not in 'HOL.thy' (and parents) + uncaught exception ERROR*) + + +fun parse' (thy:theory') (ct:cterm') = + case parse ((the o assoc')(!theory',thy)) ct of + NONE => NONE + | SOME ct => SOME ((term2str (term_of ct)):cterm'); + + +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) +fun rewrite (thy':theory') (rew_ord:rew_ord') (rls:rls') + (put_asm:bool) (thm:thm') (ct:cterm') = +(* val (rew_ord, rls, thm, ct) = (rew_ord', id_rls rls', thm', f); + *) + let val thy = (the o assoc')(!theory',thy'); + in + case rewrite_ thy + ((the o assoc')(!rew_ord',rew_ord))((#2 o the o assoc')(!ruleset',rls)) + put_asm ((assoc_thm' thy) thm) + ((term_of o the o (parse thy)) ct) of + NONE => NONE + | SOME (t, ts) => SOME (term2str t, terms2str ts) + end; + +(* +val thy = "RatArith.thy"; +val rew_ord = "dummy_ord"; +> val rls = "eval_rls"; +val put_asm = true; +val thm = ("square_equation_left",""); +val ct = "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; + +val Zthy = ((the o assoc')(!theory',thy)); +val Zrew_ord = ((the o assoc')(!rew_ord',rew_ord)); +val Zrls = ((the o assoc')(!ruleset',rls)); +val Zput_asm = put_asm; +val Zthm = ((the o (assoc'_thm' thy)) thm); +val Zct = ((the o (parse ((the o assoc')(!theory',thy)))) ct); + +rewrite_ Zthy Zrew_ord Zrls Zput_asm Zthm Zct; + + use"Isa99/interface_ME_ISA.sml"; +*) + +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) +fun rewrite_set (thy':theory') (put_asm:bool) + (rls:rls') (ct:cterm') = + let val thy = (the o assoc')(!theory',thy'); + in + case rewrite_set_ thy put_asm ((#2 o the o assoc')(!ruleset',rls)) + ((term_of o the o (parse thy)) ct) of + NONE => NONE + | SOME (t, ts) => SOME (term2str t, terms2str ts) + end; + +(*evaluate list-expressions + should work on term, and stand in Isa99/rewrite-parse.sml, + but there list_rls <- eval_binop is not yet defined*) +(*fun eval_listexpr' ct = + let val rew = rewrite_set "ListC.thy" false "list_rls" ct; + in case rew of + SOME (res,_) => res + | NONE => ct end;-----------------30.9.02---*) +fun eval_listexpr_ thy srls t = +(* val (thy, srls, t) = + ((assoc_thy th), sr, (subst_atomic (upd_env_opt E (a,v)) t)); + *) + let val rew = rewrite_set_ thy false srls t; + in case rew of + SOME (res,_) => res + | NONE => t end; + + +fun get_calculation' (thy:theory') op_ (ct:cterm') = + case get_calculation_ ((the o assoc')(!theory',thy)) op_ + ((uminus_to_string o term_of o the o + (parse ((the o assoc')(!theory',thy)))) ct) of + NONE => NONE + | SOME (thmid, thm) => + SOME ((thmid, string_of_thmI thm):thm'); + +fun calculate (thy':theory') op_ (ct:cterm') = + let val thy = (the o assoc')(!theory',thy'); + in + case calculate_ thy op_ + ((term_of o the o (parse thy)) ct) of + NONE => NONE + | SOME (ct,(thmID,thm)) => + SOME (term2str ct, + (thmID, string_of_thmI thm):thm') + end; +(* +fun instantiate'' thy' subs ((thmid,ct'):thm') = + let val thmid_ = implode ("#"::(explode thmid)) (*see type thm'*) + in (thmid_, (string_of_thmI o (read_instantiate subs)) + ((the o (assoc_thm' thy')) (thmid_,ct'))):thm' end; + +fun instantiate_rls' thy' subs (rls:rls') = + rls2rls' (instantiate_rls subs ((the o (assoc_rls thy')) rls)):rlsdat'; + +... problem with these functions: +> val thm = mk_thm thy "(bdv + a = b) = (bdv = b - a)"; +val thm = "(bdv + a = b) = (bdv = b - a)" : thm +> show_types:=true; thm; +val it = "((bdv::'a) + (a::'a) = (b::'a)) = (bdv = b - a)" : thm +... and this doesn't match because of too general typing (?!) + and read_insitantiate doesn't instantiate the types (?!) +=== solutions: +(1) hard-coded type-instantiation ("'a", "RatArith.rat") +(2) instantiate', instantiate ... no help by isabelle-users@ !!! +=== conclusion: + rewrite_inst, rewrite_set_inst circumvent the problem, + according functions out-commented with 'instantiate'' +*) + +(* instantiate'' +fun instantiate'' thy' subs ((thmid,ct'):thm') = + let + val thmid_ = implode ("#"::(explode thmid)); (*see type thm'*) + val thy = (the o assoc')(!theory',thy'); + val typs = map (#T o rep_cterm o the o (parse thy)) + ((snd o split_list) subs); + val ctyps = map + ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o (parse thy)) + ((snd o split_list) subs); + +> val thy' = "RatArith.thy"; +> val subs = [("bdv","x::rat"),("zzz","z::nat")]; +> (the o (parse ((the o assoc')(!theory',thy')))) "x::rat"; +> (#T o rep_cterm o the o (parse ((the o assoc')(!theory',thy')))); + +> val ctyp = ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o + (parse ((the o assoc')(!theory',thy')))) "x::rat"; +> val bdv = (the o (parse thy)) "bdv"; +> val x = (the o (parse thy)) "x"; +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add) + handle e => print_exn e; +uncaught exception THM + raised at: thm.ML:1085.18-1085.69 + thm.ML:1092.34 + goals.ML:536.61 + +> val bdv = (the o (parse thy)) "bdv::nat"; +> val x = (the o (parse thy)) "x::nat"; +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add) + handle e => print_exn e; +uncaught exception THM + raised at: thm.ML:1085.18-1085.69 + thm.ML:1092.34 + goals.ML:536.61 + +> (instantiate' [SOME ctyp] [] isolate_bdv_add) + handle e => print_exn e; +uncaught exception TYPE + raised at: drule.ML:613.13-615.44 + goals.ML:536.61 + +> val repct = (rep_cterm o the o (parse ((the o assoc')(!theory',thy')))) "x::rat"; +*) + +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) +fun rewrite_inst (thy':theory') (rew_ord:rew_ord') (rls:rls') + (put_asm:bool) subs (thm:thm') (ct:cterm') = + let + val thy = (the o assoc')(!theory',thy'); + val thm = assoc_thm' thy thm; (*28.10.02*) + (*val subthm = read_instantiate subs ((assoc_thm' thy) thm)*) + in + case rewrite_ thy + ((the o assoc')(!rew_ord',rew_ord)) ((#2 o the o assoc')(!ruleset',rls)) + put_asm (*sub*)thm ((term_of o the o (parse thy)) ct) of + NONE => NONE + | SOME (ctm, ctms) => + SOME ((term2str ctm):cterm', (map term2str ctms):cterm' list) + end; + +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) +fun rewrite_set_inst (thy':theory') (put_asm:bool) + subs' (rls:rls') (ct:cterm') = + let + val thy = (the o assoc')(!theory',thy'); + val rls = assoc_rls rls + val subst = subs'2subst thy subs' + (*val subrls = instantiate_rls subs ((the o assoc')(!ruleset',rls))*) + in case rewrite_set_inst_ thy put_asm subst (*sub*)rls + ((term_of o the o (parse thy)) ct) of + NONE => NONE + | SOME (t, ts) => SOME (term2str t, terms2str ts) + end; + + +(*vor check_elementwise: SqRoot_eval_rls .. wie *_simplify ?! TODO *) +fun eval_true' (thy':theory') (rls':rls') (Const ("True",_)) = true + + | eval_true' (thy':theory') (rls':rls') (t:term) = +(* val thy'="Isac.thy"; val rls'="eval_rls"; val t=hd pres'; + *) + let val ct' = term2str t; + in case rewrite_set thy' false rls' ct' of + SOME ("True",_) => true + | _ => false + end; +fun eval_true_ _ _ (Const ("True",_)) = true + | eval_true_ (thy':theory') rls t = + case rewrite_set_ (assoc_thy thy') false rls t of + SOME (Const ("True",_),_) => true + | _ => false; + +(* +val test_rls = + Rls{preconds = [], rew_ord = ("sqrt_right",sqrt_right), + rules = [Calc ("matches",eval_matches "") + ], + scr = Script ((term_of o the o (parse thy)) + "empty_script") + }:rls; + + + + rewrite_set_ Isac.thy eval_rls false test_rls + ((the o (parse thy)) "matches (?a = ?b) (x = #0)"); + val xxx = (term_of o the o (parse thy)) + "matches (?a = ?b) (x = #0)"; + eval_matches """" xxx thy; +SOME ("matches (?a = ?b) (x + #1 + #-1 * #2 = #0) = True", + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) + + + + rewrite_set_ Isac.thy eval_rls false eval_rls + ((the o (parse thy)) "contains_root (sqrt #0)"); +val it = SOME ("True",[]) : (cterm * cterm list) option + +*) + + +(*----------WN:16.5.03 stuff below considered illdesigned, thus coded from scratch in appl.sml fun check_elementwise +datatype det = TRUE | FALSE | INDET;(*FIXXME.WN:16.5.03 + introduced with quick-and-dirty code*) +fun determine dts = + let val false_indet = + filter_out ((curry op= TRUE) o (#1:det * term -> det)) dts + val ts = map (#2: det * term -> term) dts + in if nil = false_indet then (TRUE, ts) + else if nil = filter ((curry op= FALSE) o (#1:det * term -> det)) + false_indet + then (INDET, ts) + else (FALSE, ts) end; +(* val dts = [(INDET,e_term), (FALSE,HOLogic.false_const), + (INDET,e_term), (TRUE,HOLogic.true_const)]; + determine dts; +val it = + (FALSE, + [Const ("empty","'a"),Const ("False","bool"),Const ("empty","'a"), + Const ("True","bool")]) : det * term list*) + +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*) +if cs = [HOLogic.true_const] orelse cs = [] then (TRUE, []) + else if cs = [HOLogic.false_const] then (FALSE, cs) + else + let fun eval t = + let val taopt = rewrite__set_ thy 1 false [] rls t + in case taopt of + SOME (t,_) => + if t = HOLogic.true_const then (TRUE, t) + else if t = HOLogic.false_const then (FALSE, t) + else (INDET, t) + | NONE => (INDET, t) end + in (determine o (map eval)) cs end; +WN.16.5.0-------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/scrtools.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/scrtools.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,491 @@ +(* tools which depend on Script.thy and thus are not in term.sml + (c) Walther Neuper 2000 + +use"ProgLang/scrtools.sml"; +use"scrtools.sml"; +*) + + +fun is_reall_dsc + (Const(_,Type("fun",[Type("List.list", + [Type ("real",[])]),_]))) = true + | is_reall_dsc + (Const(_,Type("fun",[Type("List.list", + [Type ("real",[])]),_])) $ t) = true + | is_reall_dsc _ = false; +fun is_booll_dsc + (Const(_,Type("fun",[Type("List.list", + [Type ("bool",[])]),_]))) = true + | is_booll_dsc + (Const(_,Type("fun",[Type("List.list", + [Type ("bool",[])]),_])) $ t) = true + | is_booll_dsc _ = false; +(* +> val t = (term_of o the o (parse thy)) "relations"; +> atomtyp (type_of t); +*** Type (fun,[ +*** Type (List.list,[ +*** Type (bool,[]) +*** ] +*** Type (Tools.una,[]) +*** ] +> is_booll_dsc t; +val it = true : bool +> is_reall_dsc t; +val it = false : bool +*) + +fun is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_]))) = true + | is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_])) $ t) = true + (*WN:8.5.03: ??? ~~~~ ???*) + | is_list_dsc _ = false; +(* +> val t = str2term "someList"; +> is_list_dsc t; +val it = true : bool + +> val t = (term_of o the o (parse thy)) + "additional_relations [a=b,c=(d::real)]"; +> is_list_dsc t; +val it = true : bool +> is_list_dsc (head_of t); +val it = true : bool + +> val t = (term_of o the o (parse thy))"max_relation (A=#2*a*b-a^^^#2)"; +> is_list_dsc t; +val it = false : bool +> is_list_dsc (head_of t); +val it = false : bool +> val t = (term_of o the o (parse thy)) "testdscforlist"; +> is_list_dsc (head_of t); +val it = true : bool +*) + + +fun is_unl (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true + | is_unl _ = false; +(* +> val t = str2term "someList"; is_unl t; +val it = true : bool +> val t = (term_of o the o (parse thy)) "maximum"; +> is_unl t; +val it = false : bool +*) + +fun is_dsc (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) = true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.una",_)]))) = true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.str",_)]))) = true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) = true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))= true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.tobooll",_)])))= true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.unknow",_)])))= true + | is_dsc (Const(_,Type("fun",[_,Type("Tools.cpy",_)])))= true + | is_dsc _ = false; +fun is_dsc term = + (case (range_type o type_of) term of + Type("Tools.nam",_) => true + | Type("Tools.una",_) => true + | Type("Tools.unl",_) => true + | Type("Tools.str",_) => true + | Type("Tools.toreal",_) => true + | Type("Tools.toreall",_) => true + | Type("Tools.tobooll",_) => true + | Type("Tools.unknow",_) => true + | Type("Tools.cpy",_) => true + | _ => false) + handle Match => false; + + +(* +val t as t1 $ t2 = str2term "antiDerivativeName M_b"; +val Const (_, Type ("fun", [Type ("fun", _), Type ("Tools.una",[])])) $ _ = t; +is_dsc t1; + +> val t = (term_of o the o (parse thy)) "maximum"; +> is_dsc t; +val it = true : bool +> val t = (term_of o the o (parse thy)) "testdscforlist"; +> is_dsc t; +val it = true : bool + +> val t = (head_of o term_of o the o (parse thy)) "maximum A"; +> is_dsc t; +val it = true : bool +> val t = (head_of o term_of o the o (parse thy)) + "fixedValues [R=(R::real)]"; +> is_dsc t; +val it = true : bool +*) + + +(*make the term 'Subproblem (domID, pblID)' to a formula for frontend; + needs to be here after def. Subproblem in Script.thy*) +val t as (subpbl_t $ (pair_t $ Free (domID,_) $ pblID)) = + (term_of o the o (parse @{theory Script})) + "Subproblem (Isac,[equation,univar])"; +val t as (pbl_t $ _) = + (term_of o the o (parse @{theory Script})) + "Problem (Isac,[equation,univar])"; +val Free (_, ID_type) = (term_of o the o (parse @{theory Script})) "x::ID"; + + +fun subpbl domID pblID = + subpbl_t $ (pair_t $ Free (domID,ID_type) $ + (((list2isalist ID_type) o (map (mk_free ID_type))) pblID)); +(*> subpbl "Isac" ["equation","univar"] = t; +val it = true : bool *) + + +fun pblterm (domID:domID) (pblID:pblID) = + pbl_t $ (pair_t $ Free (domID,ID_type) $ + (((list2isalist ID_type) o (map (mk_free ID_type))) pblID)); + + +(**.construct scr-env from scr(created automatically) and Rewrite_Set.**) + +fun one_scr_arg (Const _ $ arg $ _) = arg + | one_scr_arg t = raise error ("one_scr_arg: called by "^(term2str t)); +fun two_scr_arg (Const _ $ a1 $ a2 $ _) = (a1, a2) + | two_scr_arg t = raise error ("two_scr_arg: called by "^(term2str t)); + + +(**.generate calc from a script.**) + +(*.instantiate a stactic or scriptexpr, and ev. attach (curried) argument +args: + E environment + v current value, is attached to curried stactics + stac stactic to be instantiated +precond: + not (a = NONE) /\ (v = e_term) /\ (stac curried, i.e. without last arg.) + this ........................ is the initialization for assy with l=[], + but the 1st stac is + (a) curried: then (a = SOME _), or + (b) not curried: then the values of the initialization are not used +.*) +datatype stacexpr = STac of term | Expr of term +fun rep_stacexpr (STac t ) = t + | rep_stacexpr (Expr t) = + raise error ("rep_stacexpr called with t= "^(term2str t)); + +type env = (term * term) list; + +(*update environment; t <> empty if coming from listexpr*) +fun upd_env (env:env) (v,t) = + let val env' = if t = e_term then env else overwrite (env,(v,t)); + (*val _= writeln("### upd_env: = "^(subst2str env'));*) + in env' end; + +(*.substitute the scripts environment in a leaf of the scripts parse-tree + and attach the curried argument of a tactic, if any. + a leaf is either a tactic or an 'exp' in 'let v = expr' + where 'exp' does not contain a tactic. +CAUTION: (1) currying with @@ requires 2 patterns for each tactic + (2) the non-curried version must return NONE for a + (3) non-matching patterns become an Expr by fall-through. +WN060906 quick and dirty fix: due to (2) a is returned, too.*) +fun subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ $ _ ))= + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ ))= + (a, (*in these cases we hope, that a = SOME _*) + STac (case a of SOME a' => (subst_atomic E (t $ a')) + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v + (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _))= + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ _ ))= + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ )) = + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ )) = + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ )) = + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v + (t as (Const("Script.Check'_elementwise",_) $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const("Script.Check'_elementwise",_) $ _ )) = + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_) $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_))) = (*t $ v*) + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + | subst_stacexpr E a v (t as (Const ("Script.SubProblem",_) $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Take",_) $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ $ _ )) = + (NONE, STac (subst_atomic E t)) + + | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ )) = + (a, STac (case a of SOME a' => subst_atomic E (t $ a') + | NONE => ((subst_atomic E t) $ v))) + + (*now all tactics are matched out and this leaf must be without a tactic*) + | subst_stacexpr E a v t = + (a, Expr (subst_atomic (case a of SOME a => upd_env E (a,v) + | NONE => E) t)); +(*> val t = str2term "SubProblem(Test_, [linear, univariate, equation, test], [Test, solve_linear]) [bool_ e_, real_ v_]"; +> subst_stacexpr [] NONE e_term t;*) + + +fun stacpbls (h $ body) = + let + fun scan ts (Const ("Let",_) $ e $ (Abs (v,T,b))) = + (scan ts e) @ (scan ts b) + | scan ts (Const ("If",_) $ c $ e1 $ e2) = (scan ts e1) @ (scan ts e2) + | scan ts (Const ("Script.While",_) $ c $ e $ _) = scan ts e + | scan ts (Const ("Script.While",_) $ c $ e) = scan ts e + | scan ts (Const ("Script.Repeat",_) $ e $ _) = scan ts e + | scan ts (Const ("Script.Repeat",_) $ e) = scan ts e + | scan ts (Const ("Script.Try",_) $ e $ _) = scan ts e + | scan ts (Const ("Script.Try",_) $ e) = scan ts e + | scan ts (Const ("Script.Or",_) $e1 $ e2 $ _) = + (scan ts e1) @ (scan ts e2) + | scan ts (Const ("Script.Or",_) $e1 $ e2) = + (scan ts e1) @ (scan ts e2) + | scan ts (Const ("Script.Seq",_) $e1 $ e2 $ _) = + (scan ts e1) @ (scan ts e2) + | scan ts (Const ("Script.Seq",_) $e1 $ e2) = + (scan ts e1) @ (scan ts e2) + | scan ts t = case subst_stacexpr [] NONE e_term t of + (_, STac _) => [t] | (_, Expr _) => [] + in (distinct o (scan [])) body end; + (*sc = Solve_root_equation ... +> val ts = stacpbls sc; +> writeln (terms2str thy ts); +["Rewrite square_equation_left True e_", + "Rewrite_Set SqRoot_simplify False e_", + "Rewrite_Set rearrange_assoc False e_", + "Rewrite_Set isolate_root False e_", + "Rewrite_Set norm_equation False e_", + "Rewrite_Set_Inst [(bdv, v_)] isolate_bdv False e_"] +*) + + + +fun is_calc (Const ("Script.Calculate",_) $ _) = true + | is_calc (Const ("Script.Calculate",_) $ _ $ _) = true + | is_calc _ = false; +fun op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_)) = op_ + | op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_) $ _) = op_ + | op_of_calc t = raise error ("op_of_calc called with"^term2str t); +(* + val Script sc = (#scr o rep_rls) Test_simplify; + val stacs = stacpbls sc; + + val calcs = filter is_calc stacs; + val ids = map op_of_calc calcs; + map (curry assoc1 (!calclist')) ids; + + (((map (curry assoc1 (!calclist'))) o (map op_of_calc) o + (filter is_calc) o stacpbls) sc):calc list; +*) + +(**.for automatic creation of scripts from rls.**) +(* naming of identifiers in scripts ???... +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t::'z) = t"; +((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o + (parse @{theory})) "(t't::'z) = t't"; +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_t::'z) = t_t"; +(* not accepted !!!...*) +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_::'z) = t_"; +((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o + (parse @{theory})) "(_t::'z) = _t"; +*) +((inst_abs @{theory}) o term_of o the o (parse @{theory})) +"Script Stepwise (t::'z) =\ + \(Repeat\ + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ + \ (Try (Repeat (Rewrite real_mult_commute False)))) \ + \ t_t)"; +val ScrStep $ _ $ _ = (*'z not affected by parse: 'a --> real*) + ((inst_abs @{theory}) o term_of o the o (parse @{theory})) + "Script Stepwise (t::'z) =\ + \(Repeat\ + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ + \ (Try (Repeat (Rewrite real_mult_commute False)))) \ + \ t_t)"; +(*WN060605 script-arg (t_::'z) and "Free (t_, 'a)" at end of body +are inconsistent !!!*) +val ScrStep_inst $ Term $ Bdv $ _=(*'z not affected by parse: 'a --> real*) + ((inst_abs @{theory}) o term_of o the o (parse @{theory})) + "Script Stepwise_inst (t::'z) (v::real) =\ + \(Repeat\ + \ ((Try (Repeat (Rewrite_Inst [(bdv,v)] real_diff_minus False))) @@ \ + \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_add_commute False))) @@\ + \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_mult_commute False)))) \ + \ t)"; +val Repeat $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Repeat (Rewrite real_diff_minus False t)"; +val Try $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Try (Rewrite real_diff_minus False t)"; +val Cal $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Calculate PLUS"; +val Ca1 $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Calculate1 PLUS"; +val Rew $ (Free (_,IDtype)) $ _ $ t = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Rewrite real_diff_minus False t"; +val Rew_Inst $ Subs $ _ $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Rewrite_Inst [(bdv,v)] real_diff_minus False"; +val Rew_Set $ _ $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Rewrite_Set real_diff_minus False"; +val Rew_Set_Inst $ _ $ _ $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + "Rewrite_Set_Inst [(bdv,v)] real_diff_minus False"; +val SEq $ _ $ _ $ _ = + ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) + " ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ + \ (Try (Repeat (Rewrite real_mult_commute False)))) t"; + +fun rule2stac _ (Thm (thmID, _)) = + Try $ (Repeat $ (Rew $ Free (thmID, IDtype) $ HOLogic.false_const)) + | rule2stac calc (Calc (c, _)) = + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) + | rule2stac calc (Cal1 (c, _)) = + Try $ (Repeat $ (Ca1 $ Free (assoc_calc (calc ,c), IDtype))) + | rule2stac _ (Rls_ rls) = + Try $ (Rew_Set $ Free (id_rls rls, IDtype) $ HOLogic.false_const); +(*val t = rule2stac [] (Thm ("real_diff_minus", num_str real_diff_minus)); +atomt t; term2str t; +val t = rule2stac calclist (Calc ("op +", eval_binop "#add_")); +atomt t; term2str t; +val t = rule2stac [] (Rls_ rearrange_assoc); +atomt t; term2str t; +*) +fun rule2stac_inst _ (Thm (thmID, _)) = + Try $ (Repeat $ (Rew_Inst $ Subs $ Free (thmID, IDtype) $ + HOLogic.false_const)) + | rule2stac_inst calc (Calc (c, _)) = + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) + | rule2stac_inst calc (Cal1 (c, _)) = + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) + | rule2stac_inst _ (Rls_ rls) = + Try $ (Rew_Set_Inst $ Subs $ Free (id_rls rls, IDtype) $ + HOLogic.false_const); +(*val t = rule2stac_inst [] (Thm ("real_diff_minus", num_str real_diff_minus)); +atomt t; term2str t; +val t = rule2stac_inst calclist (Calc ("op +", eval_binop "#add_")); +atomt t; term2str t; +val t = rule2stac_inst [] (Rls_ rearrange_assoc); +atomt t; term2str t; +*) + +(*for appropriate nesting take stacs in _reverse_ order*) +fun @@@ sts [s] = SEq $ s $ sts + | @@@ sts (s::ss) = @@@ (SEq $ s $ sts) ss; +fun @@ [stac] = stac + | @@ [s1, s2] = SEq $ s1 $ s2 (*---------vvv--*) + | @@ stacs = + let val s3::s2::ss = rev stacs + in @@@ (SEq $ s2 $ s3) ss end; +(* + val rules = (#rules o rep_rls) isolate_root; + val rs = map (rule2stac calclist) rules; + val tt = @@ rs; + atomt tt; writeln (term2str tt); + *) + +val contains_bdv = (not o null o (filter is_bdv) o ids2str o #prop o rep_thm); + +(*.does a rule contain a 'bdv'; descend recursively into Rls_.*) +fun contain_bdv [] = false + | contain_bdv (Thm (_, thm)::rs) = + if (not o contains_bdv) thm + then contain_bdv rs + else true + | contain_bdv (Calc _ ::rs) = contain_bdv rs + | contain_bdv (Cal1 _ ::rs) = contain_bdv rs + | contain_bdv (Rls_ rls ::rs) = + contain_bdv (get_rules rls) orelse contain_bdv rs + | contain_bdv (r::_) = + raise error ("contain_bdv called with ["^(id_rule r)^",...]"); + +fun rules2scr_Rls calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*) + if contain_bdv rules + then ScrStep_inst $ Term $ Bdv $ + (Repeat $ (((@@ o (map (rule2stac_inst calc))) rules) $ e_term)) + else ScrStep $ Term $ + (Repeat $ (((@@ o (map (rule2stac calc))) rules) $ e_term)); +(* val (calc, rules) = (!calclist', rules); + *) +fun rules2scr_Seq calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*) + if contain_bdv rules + then ScrStep_inst $ Term $ Bdv $ + (((@@ o (map (rule2stac_inst calc))) rules) $ e_term) + else ScrStep $ Term $ + (((@@ o (map (rule2stac calc))) rules) $ e_term); + +(*.prepare the input for an rls for use: + # generate a script for stepwise execution of the rls + # filter the operators for Calc out of the script + !!!use this function in ruleset' := !!! .*) +fun prep_rls Erls = raise error "prep_rls not impl. for Erls" + | prep_rls (Rls {id,preconds,rew_ord,erls,srls,calc,rules,...}) = + let val sc = (rules2scr_Rls (!calclist') rules) + in Rls {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls, + srls=srls, + calc = (*FIXXXME.040207 use also for met*) + ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o + (filter is_calc) o stacpbls) sc, + rules=rules, + scr = Script sc} end +(* val (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = add_new_c; + *) + | prep_rls (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = + let val sc = (rules2scr_Seq (!calclist') rules) + in Seq {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls, + srls=srls, + calc = ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o + (filter is_calc) o stacpbls) sc, + rules=rules, + scr = Script sc} end + | prep_rls (Rrls {id,...}) = + raise error ("prep_rls not required for Rrls \""^id^"\""); +(* + val Script sc = (#scr o rep_rls o prep_rls) isolate_root; + (writeln o term2str) sc; + val Script sc = (#scr o rep_rls o prep_rls) isolate_bdv; + (writeln o term2str) sc; + *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ProgLang/term.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/isac/ProgLang/term.sml Wed Aug 25 16:20:07 2010 +0200 @@ -0,0 +1,1343 @@ +(* extends Isabelle/src/Pure/term.ML + (c) Walther Neuper 1999 + +use"ProgLang/term.sml"; +use"term.sml"; +*) + +(* +> (cterm_of thy) a_term; +val it = "empty" : cterm *) + +(*2003 fun match thy t pat = + (snd (Pattern.match (Sign.tsig_of (sign_of thy)) (pat, t))) + handle _ => []; +fn : theory -> + Term.term -> Term.term -> (Term.indexname * Term.term) list*) +(*see src/Tools/eqsubst.ML fun clean_match*) +(*2003 fun matches thy tm pa = if match thy tm pa = [] then false else true;*) +fun matches thy tm pa = + (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true) + handle _ => false + +fun atomtyp t = (*see raw_pp_typ*) + let + fun ato n (Type (s,[])) = + ("\n*** "^indent n^"Type ("^s^",[])") + | ato n (Type (s,Ts)) = + ("\n*** "^indent n^"Type ("^s^",["^ atol (n+1) Ts) + + | ato n (TFree (s,sort)) = + ("\n*** "^indent n^"TFree ("^s^",["^ strs2str' sort) + + | ato n (TVar ((s,i),sort)) = + ("\n*** "^indent n^"TVar (("^s^","^ + string_of_int i ^ strs2str' sort) + and atol n [] = + ("\n*** "^indent n^"]") + | atol n (T::Ts) = (ato n T ^ atol n Ts) +(*in print (ato 0 t ^ "\n") end; TODO TUM10*) +in writeln(ato 0 t) end; + +(*Prog.Tutorial.p.34*) +local + fun pp_pair (x, y) = Pretty.list "(" ")" [x, y] + fun pp_list xs = Pretty.list "[" "]" xs + fun pp_str s = Pretty.str s + fun pp_qstr s = Pretty.quote (pp_str s) + fun pp_int i = pp_str (string_of_int i) + fun pp_sort S = pp_list (map pp_qstr S) + fun pp_constr a args = Pretty.block [pp_str a, Pretty.brk 1, args] +in +fun raw_pp_typ (TVar ((a, i), S)) = + pp_constr "TVar" (pp_pair (pp_pair (pp_qstr a, pp_int i), pp_sort S)) + | raw_pp_typ (TFree (a, S)) = + pp_constr "TFree" (pp_pair (pp_qstr a, pp_sort S)) + | raw_pp_typ (Type (a, tys)) = + pp_constr "Type" (pp_pair (pp_qstr a, pp_list (map raw_pp_typ tys))) +end +(* install +PolyML.addPrettyPrinter + (fn _ => fn _ => ml_pretty o Pretty.to_ML o raw_pp_typ); +de-install +PolyML.addPrettyPrinter + (fn _ => fn _ => ml_pretty o Pretty.to_ML o Proof_Display.pp_typ Pure.thy); +*) + +(* +> val T = (type_of o term_of o the o (parse thy)) "a::[real,int] => nat"; +> atomtyp T; +*** Type (fun,[ +*** Type (RealDef.real,[]) +*** Type (fun,[ +*** Type (IntDef.int,[]) +*** Type (nat,[]) +*** ] +*** ] +*) + +fun atomt t = + let fun ato (Const(a,T)) n = + ("\n*** "^indent n^"Const ("^a^")") + | ato (Free (a,T)) n = + ("\n*** "^indent n^"Free ("^a^", "^")") + | ato (Var ((a,ix),T)) n = + ("\n*** "^indent n^"Var (("^a^", "^(string_of_int ix)^"), "^")") + | ato (Bound ix) n = + ("\n*** "^indent n^"Bound "^(string_of_int ix)) + | ato (Abs(a,T,body)) n = + ("\n*** "^indent n^"Abs("^a^",..")^ato body (n+1) + | ato (f$t') n = (ato f n; ato t' (n+1)) + in writeln("\n*** -------------"^ ato t 0 ^"\n***") end; + +fun term_detail2str t = + let fun ato (Const (a, T)) n = + "\n*** "^indent n^"Const ("^a^", "^string_of_typ T^")" + | ato (Free (a, T)) n = + "\n*** "^indent n^"Free ("^a^", "^string_of_typ T^")" + | ato (Var ((a, ix), T)) n = + "\n*** "^indent n^"Var (("^a^", "^string_of_int ix^"), "^ + string_of_typ T^")" + | ato (Bound ix) n = + "\n*** "^indent n^"Bound "^string_of_int ix + | ato (Abs(a, T, body)) n = + "\n*** "^indent n^"Abs ("^a^", "^ + (string_of_typ T)^",.." + ^ato body (n + 1) + | ato (f $ t') n = ato f n^ato t' (n+1) + in "\n*** "^ato t 0^"\n***" end; +fun atomty t = (writeln o term_detail2str) t; + +fun term_str thy (Const(s,_)) = s + | term_str thy (Free(s,_)) = s + | term_str thy (Var((s,i),_)) = s^(string_of_int i) + | term_str thy (Bound i) = "B."^(string_of_int i) + | term_str thy (Abs(s,_,_)) = s + | term_str thy t = raise error("term_str not for "^term2str t); + +(*.contains the fst argument the second argument (a leave! of term).*) +fun contains_term (Abs(_,_,body)) t = contains_term body t + | contains_term (f $ f') t = + contains_term f t orelse contains_term f' t + | contains_term s t = t = s; +(*.contains the term a VAR(("*",_),_) ?.*) +fun contains_Var (Abs(_,_,body)) = contains_Var body + | contains_Var (f $ f') = contains_Var f orelse contains_Var f' + | contains_Var (Var _) = true + | contains_Var _ = false; +(* contains_Var (str2term "?z = 3") (*true*); + contains_Var (str2term "z = 3") (*false*); + *) + +(*fun int_of_str str = + let val ss = explode str + val str' = case ss of + "("::s => drop_last s | _ => ss + in case BasisLibrary.Int.fromString (implode str') of + SOME i => SOME i + | NONE => NONE end;*) +fun int_of_str str = + let val ss = explode str + val str' = case ss of + "("::s => drop_last s | _ => ss + in (SOME (Thy_Output.integer (implode str'))) handle _ => NONE end; +(* +> int_of_str "123"; +val it = SOME 123 : int option +> int_of_str "(-123)"; +val it = SOME 123 : int option +> int_of_str "#123"; +val it = NONE : int option +> int_of_str "-123"; +val it = SOME ~123 : int option +*) +fun int_of_str' str = + case int_of_str str of + SOME i => i + | NONE => raise TERM ("int_of_string: no int-string",[]); +val str2int = int_of_str'; + +fun is_numeral str = case int_of_str str of + SOME _ => true + | NONE => false; +val is_no = is_numeral; +fun is_num (Free (s,_)) = if is_numeral s then true else false + | is_num _ = false; +(*> +> is_num ((term_of o the o (parse thy)) "#1"); +val it = true : bool +> is_num ((term_of o the o (parse thy)) "#-1"); +val it = true : bool +> is_num ((term_of o the o (parse thy)) "a123"); +val it = false : bool +*) + +(*fun int_of_Free (Free (intstr, _)) = + (case BasisLibrary.Int.fromString intstr of + SOME i => i + | NONE => raise error ("int_of_Free ( "^ intstr ^", _)")) + | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");*) +fun int_of_Free (Free (intstr, _)) = (Thy_Output.integer intstr + handle _ => raise error ("int_of_Free ( "^ intstr ^", _)")) + | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )"); + +fun vars t = + let + fun scan vs (Const(s,T)) = vs + | scan vs (t as Free(s,T)) = if is_no s then vs else t::vs + | scan vs (t as Var((s,i),T)) = t::vs + | scan vs (Bound i) = vs + | scan vs (Abs(s,T,t)) = scan vs t + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) + in (distinct o (scan [])) t end; + +fun is_Free (Free _) = true + | is_Free _ = false; +fun is_fun_id (Const _) = true + | is_fun_id (Free _) = true + | is_fun_id _ = false; +fun is_f_x (f $ x) = is_fun_id f andalso is_Free x + | is_f_x _ = false; +(* is_f_x (str2term "q_0/2 * L * x") (*false*); + is_f_x (str2term "M_b x") (*true*); + *) +fun vars_str t = + let + fun scan vs (Const(s,T)) = vs + | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs + | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs + | scan vs (Bound i) = vs + | scan vs (Abs(s,T,t)) = scan vs t + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) + in (distinct o (scan [])) t end; + +fun ids2str t = + let + fun scan vs (Const(s,T)) = if is_no s then vs else s::vs + | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs + | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs + | scan vs (Bound i) = vs + | scan vs (Abs(s,T,t)) = scan (s::vs) t + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) + in (distinct o (scan [])) t end; +fun is_bdv str = + case explode str of + "b"::"d"::"v"::_ => true + | _ => false; +fun is_bdv_ (Free (s,_)) = is_bdv s + | is_bdv_ _ = false; + +fun free2str (Free (s,_)) = s + | free2str t = raise error ("free2str not for "^ term2str t); +fun free2int (t as Free (s, _)) = ((str2int s) + handle _ => raise error ("free2int: "^term_detail2str t)) + | free2int t = raise error ("free2int: "^term_detail2str t); + +(*27.8.01: unused*) +fun var2free (t as Const(s,T)) = t + | var2free (t as Free(s,T)) = t + | var2free (Var((s,i),T)) = Free(s,T) + | var2free (t as Bound i) = t + | var2free (Abs(s,T,t)) = Abs(s,T,var2free t) + | var2free (t1 $ t2) = (var2free t1) $ (var2free t2); + +(*27.8.01: doesn't find some subterm ???!???*) +(*2010 Logic.varify !!!*) +fun free2var (t as Const(s,T)) = t + | free2var (t as Free(s,T)) = if is_no s then t else Var((s,0),T) + | free2var (t as Var((s,i),T)) = t + | free2var (t as Bound i) = t + | free2var (Abs(s,T,t)) = Abs(s,T,free2var t) + | free2var (t1 $ t2) = (free2var t1) $ (free2var t2); + + +fun mk_listT T = Type ("List.list", [T]); +fun list_const T = + Const("List.list.Cons", [T, mk_listT T] ---> mk_listT T); +(*28.8.01: TODO: get type from head of list: 1 arg less!!!*) +fun list2isalist T [] = Const("List.list.Nil",mk_listT T) + | list2isalist T (t::ts) = (list_const T) $ t $ (list2isalist T ts); +(* +> val tt = (term_of o the o (parse thy)) "R=(R::real)"; +> val TT = type_of tt; +> val ss = list2isalist TT [tt,tt,tt]; +> (cterm_of thy) ss; +val it = "[R = R, R = R, R = R]" : cterm *) + +fun isapair2pair (Const ("Pair",_) $ a $ b) = (a,b) + | isapair2pair t = + raise error ("isapair2pair called with "^term2str t); + +val listType = Type ("List.list",[Type ("bool",[])]); +fun isalist2list ls = + let + fun get es (Const("List.list.Cons",_) $ t $ ls) = get (t::es) ls + | get es (Const("List.list.Nil",_)) = es + | get _ t = + raise error ("isalist2list applied to NON-list '"^term2str t^"'") + in (rev o (get [])) ls end; +(* +> val il = str2term "[a=b,c=d,e=f]"; +> val l = isalist2list il; +> (writeln o terms2str) l; +["a = b","c = d","e = f"] + +> val il = str2term "ss___::bool list"; +> val l = isalist2list il; +[Free ("ss___", "bool List.list")] +*) + + +(*review Isabelle2009/src/HOL/Tools/hologic.ML*) +val prop = Type ("prop",[]); (* ~/Diss.99/Integers-Isa/tools.sml*) +val bool = Type ("bool",[]); (* 2002 Integ.int *) +val Trueprop = Const("Trueprop",bool-->prop); +fun mk_prop t = Trueprop $ t; +val true_as_term = Const("True",bool); +val false_as_term = Const("False",bool); +val true_as_cterm = cterm_of (theory "HOL") true_as_term; +val false_as_cterm = cterm_of (theory "HOL") false_as_term; + +infixr 5 -->; (*2002 /Pure/term.ML *) +infixr --->; (*2002 /Pure/term.ML *) +fun S --> T = Type("fun",[S,T]); (*2002 /Pure/term.ML *) +val op ---> = foldr (op -->); (*2002 /Pure/term.ML *) +fun list_implies ([], B) = B : term (*2002 /term.ML *) + | list_implies (A::AS, B) = Logic.implies $ A $ list_implies(AS,B); + + + +(** substitution **) + +fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = (* = thm.ML *) + match_bvs(s, t, if x="" orelse y="" then al + else (x,y)::al) + | match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al)) + | match_bvs(_,_,al) = al; +fun ren_inst(insts,prop,pat,obj) = (* = thm.ML *) + let val ren = match_bvs(pat,obj,[]) + fun renAbs(Abs(x,T,b)) = + Abs(case assoc_string(ren,x) of NONE => x + | SOME(y) => y, T, renAbs(b)) + | renAbs(f$t) = renAbs(f) $ renAbs(t) + | renAbs(t) = t + in subst_vars insts (if null(ren) then prop else renAbs(prop)) end; + + + + + + +fun dest_equals' (Const("op =",_) $ t $ u) = (t,u)(* logic.ML: Const("=="*) + | dest_equals' t = raise TERM("dest_equals'", [t]); +val lhs_ = (fst o dest_equals'); +val rhs_ = (snd o dest_equals'); + +fun is_equality (Const("op =",_) $ t $ u) = true (* logic.ML: Const("=="*) + | is_equality _ = false; +fun mk_equality (t,u) = (Const("op =",[type_of t,type_of u]--->bool) $ t $ u); +fun is_expliceq (Const("op =",_) $ (Free _) $ u) = true + | is_expliceq _ = false; +fun strip_trueprop (Const("Trueprop",_) $ t) = t + | strip_trueprop t = t; +(* | strip_trueprop t = raise TERM("strip_trueprop", [t]); +*) + +(*.(A1==>...An==>B) goes to (A1==>...An==>).*) +fun strip_imp_prems' (Const("==>", T) $ A $ t) = + let fun coll_prems As (Const("==>", _) $ A $ t) = + coll_prems (As $ (Logic.implies $ A)) t + | coll_prems As _ = SOME As + in coll_prems (Logic.implies $ A) t end + | strip_imp_prems' _ = NONE; (* logic.ML: term -> term list*) +(* + val thm = real_mult_div_cancel1; + val prop = (#prop o rep_thm) thm; + atomt prop; +*** ------------- +*** Const ( ==>) +*** . Const ( Trueprop) +*** . . Const ( Not) +*** . . . Const ( op =) +*** . . . . Var ((k, 0), ) +*** . . . . Const ( 0) +*** . Const ( Trueprop) +*** . . Const ( op =) *** ............. + val SOME t = strip_imp_prems' ((#prop o rep_thm) thm); + atomt t; +*** ------------- +*** Const ( ==>) +*** . Const ( Trueprop) +*** . . Const ( Not) +*** . . . Const ( op =) +*** . . . . Var ((k, 0), ) +*** . . . . Const ( 0) + + val thm = real_le_anti_sym; + val prop = (#prop o rep_thm) thm; + atomt prop; +*** ------------- +*** Const ( ==>) +*** . Const ( Trueprop) +*** . . Const ( op <=) +*** . . . Var ((z, 0), ) +*** . . . Var ((w, 0), ) +*** . Const ( ==>) +*** . . Const ( Trueprop) +*** . . . Const ( op <=) +*** . . . . Var ((w, 0), ) +*** . . . . Var ((z, 0), ) +*** . . Const ( Trueprop) +*** . . . Const ( op =) +*** ............. + val SOME t = strip_imp_prems' ((#prop o rep_thm) thm); + atomt t; +*** ------------- +*** Const ( ==>) +*** . Const ( Trueprop) +*** . . Const ( op <=) +*** . . . Var ((z, 0), ) +*** . . . Var ((w, 0), ) +*** . Const ( ==>) +*** . . Const ( Trueprop) +*** . . . Const ( op <=) +*** . . . . Var ((w, 0), ) +*** . . . . Var ((z, 0), ) +*) + +(*. (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch.*) +fun ins_concl (Const("==>", T) $ A $ t) B = Logic.implies $ A $ (ins_concl t B) + | ins_concl (Const("==>", T) $ A ) B = Logic.implies $ A $ B + | ins_concl t B = raise TERM("ins_concl", [t, B]); +(* + val thm = real_le_anti_sym; + val prop = (#prop o rep_thm) thm; + val concl = Logic.strip_imp_concl prop; + val SOME prems = strip_imp_prems' prop; + val prop' = ins_concl prems concl; + prop = prop'; + atomt prop; + atomt prop'; +*) + + +fun vperm (Var _, Var _) = true (*2002 Pure/thm.ML *) + | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t) + | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) + | vperm (t, u) = (t = u); + +(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*) +fun mem_term (_, []) = false + | mem_term (t, t'::ts) = t aconv t' orelse mem_term(t,ts); +fun subset_term ([], ys) = true + | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term(xs, ys); +fun eq_set_term (xs, ys) = + xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs)); +(*a total, irreflexive ordering on index names*) +fun xless ((a,i), (b,j): indexname) = i insert_aterm(t,vars) + | Abs (_,_,body) => add_term_vars(body,vars) + | f$t => add_term_vars (f, add_term_vars(t, vars)) + | _ => vars; +fun term_vars t = add_term_vars(t,[]); + + +fun var_perm (t, u) = (*2002 Pure/thm.ML *) + vperm (t, u) andalso eq_set_term (term_vars t, term_vars u); + +(*2002 fun decomp_simp, Pure/thm.ML *) +fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs) + andalso not (is_Var lhs); + + +fun str_of_int n = + if n < 0 then "-"^((string_of_int o abs) n) + else string_of_int n; +(* +> str_of_int 1; +val it = "1" : string > str_of_int ~1; +val it = "-1" : string +*) + + +fun power b 0 = 1 + | power b n = + if n>0 then b*(power b (n-1)) + else raise error ("power "^(str_of_int b)^" "^(str_of_int n)); +(* +> power 2 3; +val it = 8 : int +> power ~2 3; +val it = ~8 : int +> power ~3 2; +val it = 9 : int +> power 3 ~2; +*) +fun gcd 0 b = b + | gcd a b = if a < b then gcd (b mod a) a + else gcd (a mod b) b; +fun sign n = if n < 0 then ~1 + else if n = 0 then 0 else 1; +fun sign2 n1 n2 = (sign n1) * (sign n2); + +infix dvd; +fun d dvd n = n mod d = 0; + +fun divisors n = + let fun pdiv ds d n = + if d=n then d::ds + else if d dvd n then pdiv (d::ds) d (n div d) + else pdiv ds (d+1) n + in pdiv [] 2 n end; + +divisors 30; +divisors 32; +divisors 60; +divisors 11; + +fun doubles ds = (* ds is ordered *) + let fun dbls ds [] = ds + | dbls ds [i] = ds + | dbls ds (i::i'::is) = if i=i' then dbls (i::ds) is + else dbls ds (i'::is) + in dbls [] ds end; +(*> doubles [2,3,4]; +val it = [] : int list +> doubles [2,3,3,5,5,7]; +val it = [5,3] : int list*) + +fun squfact 0 = 0 + | squfact 1 = 1 + | squfact n = foldl op* (1, (doubles o divisors) n); +(*> squfact 30; +val it = 1 : int +> squfact 32; +val it = 4 : int +> squfact 60; +val it = 2 : int +> squfact 11; +val it = 1 : int*) + + +fun dest_type (Type(T,[])) = T + | dest_type T = + (atomtyp T; + raise error ("... dest_type: not impl. for this type")); + +fun term_of_num ntyp n = Free (str_of_int n, ntyp); + +fun pairT T1 T2 = Type ("*", [T1, T2]); +(*> val t = str2term "(1,2)"; +> type_of t = pairT HOLogic.realT HOLogic.realT; +val it = true : bool +*) +fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2])); +(*> val t = str2term "(1,2)"; +> val Const ("Pair",pT) $ _ $ _ = t; +> pT = PairT HOLogic.realT HOLogic.realT; +val it = true : bool +*) +fun pairt t1 t2 = + Const ("Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2; +(*> val t = str2term "(1,2)"; +> val (t1, t2) = (str2term "1", str2term "2"); +> t = pairt t1 t2; +val it = true : bool*) + + +fun num_of_term (t as Free (s,_)) = + (case int_of_str s of + SOME s' => s' + | NONE => raise error ("num_of_term not for "^ term2str t)) + | num_of_term t = raise error ("num_of_term not for "^term2str t); + +fun mk_factroot op_(*=thy.sqrt*) T fact root = + Const ("op *", [T, T] ---> T) $ (term_of_num T fact) $ + (Const (op_, T --> T) $ term_of_num T root); +(* +val T = (type_of o term_of o the) (parse thy "#12::real"); +val t = mk_factroot "SqRoot.sqrt" T 2 3; +(cterm_of thy) t; +val it = "#2 * sqrt #3 " : cterm +*) +fun var_op_num v op_ optype ntyp n = + Const (op_, optype) $ v $ + Free (str_of_int n, ntyp); + +fun num_op_var v op_ optype ntyp n = + Const (op_,optype) $ + Free (str_of_int n, ntyp) $ v; + +fun num_op_num T1 T2 (op_,Top) n1 n2 = + Const (op_,Top) $ + Free (str_of_int n1, T1) $ Free (str_of_int n2, T2); +(* +> val t = num_op_num "Int" 3 4; +> atomty t; +> string_of_cterm ((cterm_of thy) t); +*) + +fun const_in str (Const _) = false + | const_in str (Free (s,_)) = if strip_thy s = str then true else false + | const_in str (Bound _) = false + | const_in str (Var _) = false + | const_in str (Abs (_,_,body)) = const_in str body + | const_in str (f$u) = const_in str f orelse const_in str u; +(* +> val t = (term_of o the o (parse thy)) "6 + 5 * sqrt 4 + 3"; +> const_in "sqrt" t; +val it = true : bool +> val t = (term_of o the o (parse thy)) "6 + 5 * 4 + 3"; +> const_in "sqrt" t; +val it = false : bool +*) + +(*used for calculating built in binary operations in Isabelle2002->Float.ML*) +(*fun calc "op +" (n1, n2) = n1+n2 + | calc "op -" (n1, n2) = n1-n2 + | calc "op *" (n1, n2) = n1*n2 + | calc "HOL.divide"(n1, n2) = n1 div n2 + | calc "Atools.pow"(n1, n2) = power n1 n2 + | calc op_ _ = raise error ("calc: operator = "^op_^" not defined");-----*) +fun calc_equ "op <" (n1, n2) = n1 < n2 + | calc_equ "op <=" (n1, n2) = n1 <= n2 + | calc_equ op_ _ = + raise error ("calc_equ: operator = "^op_^" not defined"); +fun sqrt (n:int) = if n < 0 then 0 + (*FIXME ~~~*) else (trunc o Math.sqrt o Real.fromInt) n; + +fun mk_thmid thmid op_ n1 n2 = + thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2); + +fun dest_binop_typ (Type("fun",[range,Type("fun",[arg2,arg1])])) = + (arg1,arg2,range) + | dest_binop_typ _ = raise error "dest_binop_typ: not binary"; +(* ----- +> val t = (term_of o the o (parse thy)) "#3^#4"; +> val hT = type_of (head_of t); +> dest_binop_typ hT; +val it = ("'a","nat","'a") : typ * typ * typ + ----- *) + + +(** transform binary numeralsstrings **) +(*Makarius 100308, hacked by WN*) +val numbers_to_string = + let + fun dest_num t = + (case try HOLogic.dest_number t of + SOME (T, i) => + (*if T = @{typ int} orelse T = @{typ real} then WN*) + SOME (Free (signed_string_of_int i, T)) + (*else NONE WN*) + | NONE => NONE); + + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b) + | to_str (t as (u1 $ u2)) = + (case dest_num t of + SOME t' => t' + | NONE => to_str u1 $ to_str u2) + | to_str t = perhaps dest_num t; + in to_str end + +(*.make uminus uniform: + Const ("uminus", _) $ Free ("2", "RealDef.real") --> Free ("-2", _) +to be used immediately before evaluation of numerals; +see Scripts/calculate.sml .*) +(*2002 fun(*app_num_tr'2 (Const("0",T)) = Free("0",T) + | app_num_tr'2 (Const("1",T)) = Free("1",T) + |*)app_num_tr'2 (t as Const("uminus",_) $ Free(s,T)) = + (case int_of_str s of SOME i => + if i > 0 then Free("-"^s,T) else Free(s,T) + | NONE => t) +(*| app_num_tr'2 (t as Const(s,T)) = t + | app_num_tr'2 (Const("Numeral.number_of",Type ("fun", [_, T])) $ t) = + Free(NumeralSyntax.dest_bin_str t, T) + | app_num_tr'2 (t as Free(s,T)) = t + | app_num_tr'2 (t as Var(n,T)) = t + | app_num_tr'2 (t as Bound i) = t +*)| app_num_tr'2 (Abs(s,T,body)) = Abs(s,T, app_num_tr'2 body) + | app_num_tr'2 (t1 $ t2) = (app_num_tr'2 t1) $ (app_num_tr'2 t2) + | app_num_tr'2 t = t; +*) +val uminus_to_string = + let + fun dest_num t = + (case t of + (Const ("HOL.uminus_class.uminus", _) $ Free (s, T)) => + (case int_of_str s of + SOME i => + SOME (Free (signed_string_of_int (~1 * i), T)) + | NONE => NONE) + | _ => NONE); + + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b) + | to_str (t as (u1 $ u2)) = + (case dest_num t of + SOME t' => t' + | NONE => to_str u1 $ to_str u2) + | to_str t = perhaps dest_num t; + in to_str end; + + +(*2002 fun num_str thm = + let + val {sign_ref = sign_ref, der = der, maxidx = maxidx, + shyps = shyps, hyps = hyps, (*tpairs = tpairs,*) prop = prop} = + rep_thm_G thm; + val prop' = app_num_tr'1 prop; + in assbl_thm sign_ref der maxidx shyps hyps (*tpairs*) prop' end;*) +fun num_str thm = + let val (deriv, + {thy_ref = thy_ref, tags = tags, maxidx = maxidx, shyps = shyps, + hyps = hyps, tpairs = tpairs, prop = prop}) = rep_thm_G thm + val prop' = numbers_to_string prop; + in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end; + +fun get_thm' xstring = (*?covers 2009 Thm?!, replaces 2002 fun get_thm : +val it = fn : theory -> xstring -> Thm.thm*) + Thm (xstring, + num_str (ProofContext.get_thm (thy2ctxt' "Isac") xstring)); + +(** get types of Free and Abs for parse' **) +(*11.1.00: not used, fix-typed +,*,-,^ instead *) + +val dummyT = Type ("dummy",[]); +val dummyT = TVar (("DUMMY",0),[]); + +(* assumes only 1 type for numerals + and different identifiers for Const, Free and Abs *) +fun get_types t = + let + fun get ts (Const(s,T)) = (s,T)::ts + | get ts (Free(s,T)) = if is_no s + then ("#",T)::ts else (s,T)::ts + | get ts (Var(n,T)) = ts + | get ts (Bound i) = ts + | get ts (Abs(s,T,body)) = get ((s,T)::ts) body + | get ts (t1 $ t2) = (get ts t1) @ (get ts t2) + in distinct (get [] t) end; +(* +val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; +get_types t; +*) + +(*11.1.00: not used, fix-typed +,*,-,^ instead *) +fun set_types al (Const(s,T)) = + (case assoc (al,s) of + SOME T' => Const(s,T') + | NONE => (warning ("set_types: no type for "^s); Const(s,dummyT))) + | set_types al (Free(s,T)) = + if is_no s then + (case assoc (al,"#") of + SOME T' => Free(s,T') + | NONE => (warning ("set_types: no type for numerals"); Free(s,T))) + else (case assoc (al,s) of + SOME T' => Free(s,T') + | NONE => (warning ("set_types: no type for "^s); Free(s,T))) + | set_types al (Var(n,T)) = Var(n,T) + | set_types al (Bound i) = Bound i + | set_types al (Abs(s,T,body)) = + (case assoc (al,s) of + SOME T' => Abs(s,T', set_types al body) + | NONE => (warning ("set_types: no type for "^s); + Abs(s,T, set_types al body))) + | set_types al (t1 $ t2) = (set_types al t1) $ (set_types al t2); +(* +val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; +val al = get_types t; + +val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4"; +atomty t; (* 'a *) +val t' = set_types al t; +atomty t'; (*real*) +(cterm_of thy) t'; +val it = "x = #0 + #-1 * #-4" : cterm + +val t = (term_of o the o (parse thy)) + "#5 * x + x ^^^ #2 = (#2 + x) ^^^ #2"; +atomty t; +val t' = set_types al t; +atomty t'; +(cterm_of thy) t'; +uncaught exception TYPE (*^^^ is new, NOT in al*) +*) + + +(** from Descript.ML **) + +(** decompose an isa-list to an ML-list + i.e. [] belong to the meta-language, too **) + +fun is_list ((Const("List.list.Cons",_)) $ _ $ _) = true + | is_list _ = false; +(* val (SOME ct) = parse thy "lll::real list"; +> val ty = (#t o rep_cterm) ct; +> is_list ty; +val it = false : bool +> val (SOME ct) = parse thy "[lll]"; +> val ty = (#t o rep_cterm) ct; +> is_list ty; +val it = true : bool *) + + + +fun mk_Free (s,T) = Free(s,T); +fun mk_free T s = Free(s,T); + +(*instantiate let; necessary for ass_up*) +fun inst_abs thy (Const sT) = Const sT + | inst_abs thy (Free sT) = Free sT + | inst_abs thy (Bound n) = Bound n + | inst_abs thy (Var iT) = Var iT + | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) = + let val (v',b') = variant_abs (v,T2,b); (*fun variant_abs: term.ML*) + in Const ("Let",T1) $ inst_abs thy e $ (Abs (v',T2,inst_abs thy b')) end + | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2 + | inst_abs thy t = + (writeln("inst_abs: unchanged t= "^ term2str t); + t); +(*val scr as (Script sc) = Script ((term_of o the o (parse thy)) + "Script Testeq (e_::bool) = \ + \While (contains_root e_) Do \ + \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False e_)); \ + \ e_ = Try (Repeat (Rewrite square_equation_left True e_)) \ + \ in Try (Repeat (Rewrite radd_0 False e_))) "); +ML> atomt sc; +*** Const ( Script.Testeq) +*** . Free ( e_, ) +*** . Const ( Script.While) +*** . . Const ( RatArith.contains'_root) +*** . . . Free ( e_, ) +*** . . Const ( Let) +*** . . . Const ( Script.Try) +*** . . . . Const ( Script.Repeat) +*** . . . . . Const ( Script.Rewrite) +*** . . . . . . Free ( rroot_square_inv, ) +*** . . . . . . Const ( False) +*** . . . . . . Free ( e_, ) +*** . . . Abs( e_,.. +*** . . . . Const ( Let) +*** . . . . . Const ( Script.Try) +*** . . . . . . Const ( Script.Repeat) +*** . . . . . . . Const ( Script.Rewrite) +*** . . . . . . . . Free ( square_equation_left, ) +*** . . . . . . . . Const ( True) +*** . . . . . . . . Bound 0 <-- !!! +*** . . . . . Abs( e_,.. +*** . . . . . . Const ( Script.Try) +*** . . . . . . . Const ( Script.Repeat) +*** . . . . . . . . Const ( Script.Rewrite) +*** . . . . . . . . . Free ( radd_0, ) +*** . . . . . . . . . Const ( False) +*** . . . . . . . . . Bound 0 <-- !!! +val it = () : unit +ML> atomt (inst_abs thy sc); +*** Const ( Script.Testeq) +*** . Free ( e_, ) +*** . Const ( Script.While) +*** . . Const ( RatArith.contains'_root) +*** . . . Free ( e_, ) +*** . . Const ( Let) +*** . . . Const ( Script.Try) +*** . . . . Const ( Script.Repeat) +*** . . . . . Const ( Script.Rewrite) +*** . . . . . . Free ( rroot_square_inv, ) +*** . . . . . . Const ( False) +*** . . . . . . Free ( e_, ) +*** . . . Abs( e_,.. +*** . . . . Const ( Let) +*** . . . . . Const ( Script.Try) +*** . . . . . . Const ( Script.Repeat) +*** . . . . . . . Const ( Script.Rewrite) +*** . . . . . . . . Free ( square_equation_left, ) +*** . . . . . . . . Const ( True) +*** . . . . . . . . Free ( e_, ) <-- !!! +*** . . . . . Abs( e_,.. +*** . . . . . . Const ( Script.Try) +*** . . . . . . . Const ( Script.Repeat) +*** . . . . . . . . Const ( Script.Rewrite) +*** . . . . . . . . . Free ( radd_0, ) +*** . . . . . . . . . Const ( False) +*** . . . . . . . . . Free ( e_, ) <-- ZUFALL vor 5.03!!! +val it = () : unit*) + + + + +fun inst_abs thy (Const sT) = Const sT + | inst_abs thy (Free sT) = Free sT + | inst_abs thy (Bound n) = Bound n + | inst_abs thy (Var iT) = Var iT + | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) = + let val b' = subst_bound (Free(v,T2),b); + (*fun variant_abs: term.ML*) + in Const ("Let",T1) $ inst_abs thy e $ (Abs (v,T2,inst_abs thy b')) end + | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2 + | inst_abs thy t = + (writeln("inst_abs: unchanged t= "^ term2str t); + t); +(*val scr = + "Script Make_fun_by_explicit (f_::real) (v_::real) (eqs_::bool list) = \ + \ (let h_ = (hd o (filterVar f_)) eqs_; \ + \ e_1 = hd (dropWhile (ident h_) eqs_); \ + \ vs_ = dropWhile (ident f_) (Vars h_); \ + \ v_1 = hd (dropWhile (ident v_) vs_); \ + \ (s_1::bool list)=(SubProblem(DiffApp_,[univar,equation],[no_met])\ + \ [bool_ e_1, real_ v_1])\ + \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)"; +> val ttt = (term_of o the o (parse thy)) scr; +> writeln(term2str ttt); +> atomt ttt; +*** ------------- +*** Const ( DiffApp.Make'_fun'_by'_explicit) +*** . Free ( f_, ) +*** . Free ( v_, ) +*** . Free ( eqs_, ) +*** . Const ( Let) +*** . . Const ( Fun.op o) +*** . . . Const ( List.hd) +*** . . . Const ( DiffApp.filterVar) +*** . . . . Free ( f_, ) +*** . . . Free ( eqs_, ) +*** . . Abs( h_,.. +*** . . . Const ( Let) +*** . . . . Const ( List.hd) +*** . . . . . Const ( List.dropWhile) +*** . . . . . . Const ( Atools.ident) +*** . . . . . . . Bound 0 <---- Free ( h_, ) +*** . . . . . . Free ( eqs_, ) +*** . . . . Abs( e_1,.. +*** . . . . . Const ( Let) +*** . . . . . . Const ( List.dropWhile) +*** . . . . . . . Const ( Atools.ident) +*** . . . . . . . . Free ( f_, ) +*** . . . . . . . Const ( Tools.Vars) +*** . . . . . . . . Bound 1 <---- Free ( h_, ) +*** . . . . . . Abs( vs_,.. +*** . . . . . . . Const ( Let) +*** . . . . . . . . Const ( List.hd) +*** . . . . . . . . . Const ( List.dropWhile) +*** . . . . . . . . . . Const ( Atools.ident) +*** . . . . . . . . . . . Free ( v_, ) +*** . . . . . . . . . . Bound 0 <---- Free ( vs_, ) +*** . . . . . . . . Abs( v_1,.. +*** . . . . . . . . . Const ( Let) +*** . . . . . . . . . . Const ( Script.SubProblem) +*** . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . Free ( DiffApp_, ) +*** . . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . Free ( univar, ) +*** . . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . . Free ( equation, ) +*** . . . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . Free ( no_met, ) +*** . . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . Const ( Script.bool_) +*** . . . . . . . . . . . . . Bound 2 <----- Free ( e_1, ) +*** . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . Const ( Script.real_) +*** . . . . . . . . . . . . . . Bound 0 <----- Free ( v_1, ) +*** . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . Abs( s_1,.. +*** . . . . . . . . . . . Const ( Script.Substitute) +*** . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . . . Bound 1 <----- Free ( v_1, ) +*** . . . . . . . . . . . . . . Const ( Fun.op o) +*** . . . . . . . . . . . . . . . Const ( Tools.rhs) +*** . . . . . . . . . . . . . . . Const ( List.hd) +*** . . . . . . . . . . . . . . . Bound 0 <----- Free ( s_1, ) +*** . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . . Bound 4 <----- Free ( h_, ) + +> val ttt' = inst_abs thy ttt; +> writeln(term2str ttt'); +Script Make_fun_by_explicit f_ v_ eqs_ = + ... as above ... +> atomt ttt'; +*** ------------- +*** Const ( DiffApp.Make'_fun'_by'_explicit) +*** . Free ( f_, ) +*** . Free ( v_, ) +*** . Free ( eqs_, ) +*** . Const ( Let) +*** . . Const ( Fun.op o) +*** . . . Const ( List.hd) +*** . . . Const ( DiffApp.filterVar) +*** . . . . Free ( f_, ) +*** . . . Free ( eqs_, ) +*** . . Abs( h_,.. +*** . . . Const ( Let) +*** . . . . Const ( List.hd) +*** . . . . . Const ( List.dropWhile) +*** . . . . . . Const ( Atools.ident) +*** . . . . . . . Free ( h_, ) <---- Bound 0 +*** . . . . . . Free ( eqs_, ) +*** . . . . Abs( e_1,.. +*** . . . . . Const ( Let) +*** . . . . . . Const ( List.dropWhile) +*** . . . . . . . Const ( Atools.ident) +*** . . . . . . . . Free ( f_, ) +*** . . . . . . . Const ( Tools.Vars) +*** . . . . . . . . Free ( h_, ) <---- Bound 1 +*** . . . . . . Abs( vs_,.. +*** . . . . . . . Const ( Let) +*** . . . . . . . . Const ( List.hd) +*** . . . . . . . . . Const ( List.dropWhile) +*** . . . . . . . . . . Const ( Atools.ident) +*** . . . . . . . . . . . Free ( v_, ) +*** . . . . . . . . . . Free ( vs_, ) <---- Bound 0 +*** . . . . . . . . Abs( v_1,.. +*** . . . . . . . . . Const ( Let) +*** . . . . . . . . . . Const ( Script.SubProblem) +*** . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . Free ( DiffApp_, ) +*** . . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . Free ( univar, ) +*** . . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . . Free ( equation, ) +*** . . . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . . Free ( no_met, ) +*** . . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . Const ( Script.bool_) +*** . . . . . . . . . . . . . Free ( e_1, ) <----- Bound 2 +*** . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . Const ( Script.real_) +*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 0 +*** . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . Abs( s_1,.. +*** . . . . . . . . . . . Const ( Script.Substitute) +*** . . . . . . . . . . . . Const ( List.list.Cons) +*** . . . . . . . . . . . . . Const ( Pair) +*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 1 +*** . . . . . . . . . . . . . . Const ( Fun.op o) +*** . . . . . . . . . . . . . . . Const ( Tools.rhs) +*** . . . . . . . . . . . . . . . Const ( List.hd) +*** . . . . . . . . . . . . . . . Free ( s_1, ) <----- Bound 0 +*** . . . . . . . . . . . . . Const ( List.list.Nil) +*** . . . . . . . . . . . . Free ( h_, ) <----- Bound 4 + +Note numbering of de Bruijn indexes ! + +Script Make_fun_by_explicit f_ v_ eqs_ = + let h_ = (hd o filterVar f_) eqs_; + e_1 = hd (dropWhile (ident h_ BOUND_0) eqs_); + vs_ = dropWhile (ident f_) (Vars h_ BOUND_1); + v_1 = hd (dropWhile (ident v_) vs_ BOUND_0); + s_1 = + SubProblem (DiffApp_, [univar, equation], [no_met]) + [bool_ e_1 BOUND_2, real_ v_1 BOUND_0] + in Substitute [(v_1 BOUND_1 = (rhs o hd) s_1 BOUND_0)] h_ BOUND_4 +*) + + +fun T_a2real (Type (s, [])) = + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, []) + | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts) + | T_a2real (TFree (s, srt)) = + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt) + | T_a2real (TVar (("DUMMY",_),srt)) = HOLogic.realT; + +(*FIXME .. fixes the type (+see Typefix.thy*) +fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T)) + | typ_a2real (Free( s, T)) = (Free( s, T_a2real T)) + | typ_a2real (Var( n, T)) = (Var( n, T_a2real T)) + | typ_a2real (Bound i) = (Bound i) + | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t) + | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2); +(* +----------------6.8.02--------------------------------------------------- + val str = "1"; + val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[]))); + atomty (term_of t); +*** ------------- +*** Const ( 1, 'a) + val t = (app_num_tr' o term_of) t; + atomty t; +*** ------------- +*** Const ( 1, 'a) + val t = typ_a2real t; + atomty t; +*** ------------- +*** Const ( 1, real) + + val str = "2"; + val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[]))); + atomty (term_of t); +*** ------------- +*** Const ( Numeral.number_of, bin => 'a) +*** . Const ( Numeral.bin.Bit, [bin, bool] => bin) +*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin) +*** . . . Const ( Numeral.bin.Pls, bin) +*** . . . Const ( True, bool) +*** . . Const ( False, bool) + val t = (app_num_tr' o term_of) t; + atomty t; +*** ------------- +*** Free ( 2, 'a) + val t = typ_a2real t; + atomty t; +*** ------------- +*** Free ( 2, real) +----------------6.8.02--------------------------------------------------- + + +> val str = "R"; +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); +val t = Free ("R","?DUMMY") : term +> val t' = typ_a2real t; +> (cterm_of thy) t'; +val it = "R::RealDef.real" : cterm + +> val str = "R=R"; +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); +> atomty (typ_a2real t); +*** ------------- +*** Const ( op =, [RealDef.real, RealDef.real] => bool) +*** Free ( R, RealDef.real) +*** Free ( R, RealDef.real) +> val t' = typ_a2real t; +> (cterm_of thy) t'; +val it = "(R::RealDef.real) = R" : cterm + +> val str = "fixed_values [R=R]"; +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); +> val t' = typ_a2real t; +> (cterm_of thy) t'; +val it = "fixed_values [(R::RealDef.real) = R]" : cterm +*) + +(*TODO.WN0609: parse should return a term or a string + (or even more comprehensive datastructure for error-messages) + i.e. in wrapping with SOME term or NONE the latter is not sufficient*) +(*2002 fun parseold thy str = + (let + val sgn = sign_of thy; + val t = ((*typ_a2real o*) app_num_tr'1 o term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); + in SOME (cterm_of sgn t) end) + handle _ => NONE;*) + + + +fun parseold thy str = + (let val t = ((*typ_a2real o*) numbers_to_string) + (Syntax.read_term_global thy str) + in SOME (cterm_of thy t) end) + handle _ => NONE; +(*2002 fun parseN thy str = + (let + val sgn = sign_of thy; + val t = ((*typ_a2real o app_num_tr'1 o*) term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); + in SOME (cterm_of sgn t) end) + handle _ => NONE;*) +fun parseN thy str = + (let val t = (*(typ_a2real o numbers_to_string)*) + (Syntax.read_term_global thy str) + in SOME (cterm_of thy t) end) + handle _ => NONE; +(*2002 fun parse thy str = + (let + val sgn = sign_of thy; + val t = (typ_a2real o app_num_tr'1 o term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); + in SOME (cterm_of sgn t) end) (*FIXXXXME 10.8.02: return term !!!*) + handle _ => NONE;*) +(*2010 fun parse thy str = + (let val t = (typ_a2real o app_num_tr'1) (Syntax.read_term_global thy str) + in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*) + handle _ => NONE;*) +fun parse thy str = + (let val t = (typ_a2real o numbers_to_string) + (Syntax.read_term_global thy str) + in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*) + handle _ => NONE; + +(* 10.8.02: for this reason we still have ^^^-------------------- + val thy = SqRoot.thy; + val str = "(1::real) ^ (2::nat)"; + val sgn = sign_of thy; + val ct = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e =>print_exn e; +(*1*)"(1::real) ^ 2"; + atomty (term_of ct); +*** ------------- +*** Const ( Nat.power, [real, nat] => real) +*** . Const ( 1, real) +*** . Const ( Numeral.number_of, bin => nat) +*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin) +*** . . . Const ( Numeral.bin.Bit, [bin, bool] => bin) +*** . . . . Const ( Numeral.bin.Pls, bin) +*** . . . . Const ( True, bool) +*** . . . Const ( False, bool) + val t = ((app_num_tr' o term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; + val ct = (cterm_of sgn t) handle e => print_exn e; +(*2*)"(1::real) ^ (2::nat)"; + atomty (term_of ct); +*** ------------- +*** Const ( Nat.power, [real, nat] => real) +*** . Free ( 1, real) +*** . Free ( 2, nat) (*1*) Const("2",_) (*2*) Free("2",_) + + + val str = "(2::real) ^ (2::nat)"; + val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e; +val t = "(2::real) ^ 2" : cterm + val t = ((app_num_tr' o term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; + val ct = (cterm_of sgn t) handle e => print_exn e; +Variable "2" has two distinct types +real +nat +uncaught exception TYPE + raised at: sign.ML:672.26-673.56 + goals.ML:1100.61 + + + val str = "(3::real) ^ (2::nat)"; + val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e; +val t = "(3::real) ^ 2" : cterm + val t = ((app_num_tr' o term_of) + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; + val ct = (cterm_of sgn t) handle e => print_exn e; +val ct = "(3::real) ^ (2::nat)" : cterm + + +Conclusion: The type inference allows different types + for one and the same Numeral.number_of + BUT the type inference doesn't allow + Free ( 2, real) and Free ( 2, nat) within one term +--------------- ~~~~ ~~~ *) +(* +> val (SOME ct) = parse thy "(-#5)^^^#3"; +> atomty (term_of ct); +*** ------------- +*** Const ( Nat.op ^, ['a, nat] => 'a) +*** Const ( uminus, 'a => 'a) +*** Free ( #5, 'a) +*** Free ( #3, nat) +> val (SOME ct) = parse thy "R=R"; +> atomty (term_of ct); +*** ------------- +*** Const ( op =, [real, real] => bool) +*** Free ( R, real) +*** Free ( R, real) + +THIS IS THE OUTPUT FOR VERSION (3) above at typ_a2real !!!!! +*** ------------- +*** Const ( op =, [RealDef.real, RealDef.real] => bool) +*** Free ( R, RealDef.real) +*** Free ( R, RealDef.real) *) + +(*version for testing local to theories*) +fun str2term_ thy str = (term_of o the o (parse thy)) str; +fun str2term str = (term_of o the o (parse (theory "Isac"))) str; +fun strs2terms ss = map str2term ss; +fun str2termN str = (term_of o the o (parseN (theory "Isac"))) str; + +(*+ makes a substitution from the output of Pattern.match +*) +(*fun mk_subs ((id, _):indexname, t:term) = (Free (id,type_of t), t);*) +fun mk_subs (subs: ((string * int) * (Term.typ * Term.term)) list) = +let fun mk_sub ((id, _), (ty, tm)) = (Free (id, ty), tm) in +map mk_sub subs end; + +val atomthm = atomt o #prop o rep_thm; + +(*.instantiate #prop thm with bound variables (as Free).*) +fun inst_bdv [] t = t : term + | inst_bdv (instl: (term*term) list) t = + let fun subst (v as Var((s,_),T)) = + (case explode s of + "b"::"d"::"v"::_ => + if_none (assoc(instl,Free(s,T))) (Free(s,T)) + | _ => v) + | subst (Abs(a,T,body)) = Abs(a, T, subst body) + | subst (f$t') = subst f $ subst t' + | subst t = if_none (assoc(instl,t)) t + in subst t end; + + +(*WN050829 caution: is_atom (str2term"q_0/2 * L * x") = true !!! + use length (vars term) = 1 instead*) +fun is_atom (Const ("Float.Float",_) $ _) = true + | is_atom (Const ("ComplexI.I'_'_",_)) = true + | is_atom (Const ("op *",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t + | is_atom (Const ("op +",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1 + | is_atom (Const ("op +",_) $ t1 $ + (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_))) = + is_atom t1 andalso is_atom t2 + | is_atom (Const _) = true + | is_atom (Free _) = true + | is_atom (Var _) = true + | is_atom _ = false; +(* val t = str2term "q_0/2 * L * x"; + + +*) +(*val t = str2term "Float ((1,2),(0,0))"; +> is_atom t; +val it = true : bool +> val t = str2term "Float ((1,2),(0,0)) * I__"; +> is_atom t; +val it = true : bool +> val t = str2term "Float ((1,2),(0,0)) + Float ((3,4),(0,0)) * I__"; +> is_atom t; +val it = true : bool +> val t = str2term "1 + 2*I__"; +> val Const ("op +",_) $ t1 $ (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_)) = t; +*) + +(*.adaption from Isabelle/src/Pure/term.ML; reports if ALL Free's + have found a substitution (required for evaluating the preconditions + of _incomplete_ models).*) +fun subst_atomic_all [] t = (false, (*TODO may be 'true' for some terms ?*) + t : term) + | subst_atomic_all (instl: (term*term) list) t = + let fun subst (Abs(a,T,body)) = + let val (all, body') = subst body + in (all, Abs(a, T, body')) end + | subst (f$tt) = + let val (all1, f') = subst f + val (all2, tt') = subst tt + in (all1 andalso all2, f' $ tt') end + | subst (t as Free _) = + if is_num t then (true, t) (*numerals cannot be subst*) + else (case assoc(instl,t) of + SOME t' => (true, t') + | NONE => (false, t)) + | subst t = (true, if_none (assoc(instl,t)) t) + in subst t end; + +(*.add two terms with a type given.*) +fun mk_add t1 t2 = + let val T1 = type_of t1 + val T2 = type_of t2 + in if T1 <> T2 then raise TYPE ("mk_add gets ",[T1, T2],[t1,t2]) + else (Const ("op +", [T1, T2] ---> T1) $ t1 $ t2) + end; + diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/RCODE-root.sml --- a/src/Tools/isac/RCODE-root.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -(*.evaluate isac (all the code of the kernel) and isactest - (c) Walther Neuper 1997 - - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac - - /usr/local/Isabelle2002/bin/isabelle HOL-Real - cd"~/proto2/isac/src/sml"; use"RCODE-root.sml"; - - use"ROOT.ML"; - use"RTEST-root.sml"; -.*) - -(*.please change HERE and in ROOT.ML accordingly, - if you store a new heap ...*) -val version_isac = "WN0710-calcResponse"; - -print_depth 1;(*reduces verbosity of stdout*) - -(*.this function from Isabelle2002/src/Pure/library.ML is overwritten - by some Isabelle2002 theory file; thus reestablished for isac.*) -fun find_first _ [] = NONE - | find_first pred (x :: xs) = - if pred x then SOME x else find_first pred xs; -fun swap (x, y) = (y, x); -(*HACK.WN080107*) val sstr = str; - -"**** build the isac kernel = math-engine + IsacKnowledge "; -"**** build the math-engine ******************************"; -use"library.sml"; -use"calcelems.sml"; -cd "Scripts"; - use"term_G.sml"; - use"calculate.sml"; - use"rewrite.sml"; - use_thy"Script"; -(* remove_thy"ListG"; - use_thy"~/proto2/isac/src/sml/Scripts/Script"; - *) - use"scrtools.sml"; - cd ".."; -cd "ME"; - use"mstools.sml"; - use"ctree.sml"; - use"ptyps.sml"; - use"generate.sml"; - use"calchead.sml"; - use"appl.sml"; - use"rewtools.sml"; - use"script.sml"; - use"solve.sml"; - use"inform.sml"; - use"mathengine.sml"; - cd ".."; -cd "xmlsrc"; - use"mathml.sml"; - use"datatypes.sml"; - use"pbl-met-hierarchy.sml"; - use"thy-hierarchy.sml"; - use"interface-xml.sml"; - cd ".."; -cd"FE-interface"; - use"messages.sml"; - use"states.sml"; - use"interface.sml"; - cd ".."; -use"print_exn_G.sml"; -"**** build math-engine complete *************************"; - -"**** build the IsacKnowledge ****************************"; - cd "IsacKnowledge"; - use_thy"Isac"; (*evaluates ALL thys depending on the root 'Isac'*) - - (* remove_thy"Typefix"; - use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac"; - *) - cd ".."; -"**** build IsacKnowledge complete ***********************"; -"**** build isac kernel complete *************************"; - -states:=[]; -print_depth 3; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/ROOT.ML --- a/src/Tools/isac/ROOT.ML Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,282 +0,0 @@ -(*.evaluate isac (all the code of the kernel) and isactest - (c) Walther Neuper 1997 - ---------------------------------------------------------old heap on new nb - polyisac /home/neuper/devel/isac-10/heap/HOL-Real-Isac ---------------------------------------------------------old heap on new nb - - poly /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/HOL-Real - cd"/home/neuper/proto2/isac/src/sml"; use"ROOT.ML"; - -############################# nb-setup 080917 broke the isabelle configuration; thus HOL-Real CANNOT BE RECOMPUTED todo ! - - /usr/local/Isabelle2002/bin/isabelle HOL-Real - cd"/home/neuper/proto2/isac/src/sml"; use"ROOT.ML"; - -############################# Rational-SK070730.ML ############# - - cd"/home/neuper/proto2/isac/src/sml"; use"RCODE-root.sml"; - cd"/home/neuper/proto2/isac/src/sml"; use"RTEST-root.sml"; -.*) - -(*.please change HERE and in RCODE-root accordingly, - if you store a new heap ...*) -val version_isac = "WN071206-applyTacticTW"; - -print_depth 1;(*reduces verbosity of stdout*) - -(*.these functions from Isabelle2002/src/Pure/library.ML are overwritten - by some Isabelle2002 theory file; thus reestablished for isac.*) -fun find_first _ [] = NONE - | find_first pred (x :: xs) = - if pred x then SOME x else find_first pred xs; -fun swap (x, y) = (y, x); -(*HACK.WN080107*) val sstr = str; - -"**** build the isac kernel = math-engine + IsacKnowledge "; -"**** build the math-engine ******************************"; -use"library.sml"; -use"calcelems.sml"; -check_guhs_unique := true; -cd "Scripts"; - use"term_G.sml"; - use"calculate.sml"; - use"rewrite.sml"; - use_thy"Script"; -(* remove_thy"ListG"; - use_thy"~/proto2/isac/src/sml/Scripts/Script"; - *) - use"scrtools.sml"; - cd ".."; -cd "ME"; - use"mstools.sml"; - use"ctree.sml"; - use"ptyps.sml"; - use"generate.sml"; - use"calchead.sml"; - use"appl.sml"; - use"rewtools.sml"; - use"script.sml"; - use"solve.sml"; - use"inform.sml"; - use"mathengine.sml"; - cd ".."; -cd "xmlsrc"; - use"mathml.sml"; - use"datatypes.sml"; - use"pbl-met-hierarchy.sml"; - use"thy-hierarchy.sml"; - use"interface-xml.sml"; - cd ".."; -cd"FE-interface"; - use"messages.sml"; - use"states.sml"; - use"interface.sml"; - cd ".."; -use"print_exn_G.sml"; -"**** build math-engine complete *************************"; - -"**** build the IsacKnowledge ****************************"; - cd "IsacKnowledge"; - use_thy"Isac"; (*evaluates ALL thys depending on the root 'Isac'*) - - (* remove_thy"Typefix"; - use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac"; - *) - cd ".."; -"**** build IsacKnowledge complete ***********************"; -"**** build isac kernel complete *************************"; -check_guhs_unique := false; - -"**** run the tests **************************************"; -cd "systest"; -(*+ check kbtest/diffapp.sml for additional items in met-model*) - use"root-equ.sml"; - use"script.sml"; - (* use"script_if.sml"; WN03 missing: is_rootequation_in*) - use"scriptnew.sml"; - use"subp-rooteq.sml"; - use"tacis.sml"; - use"interface-xml.sml"; - (* use"testdaten.sml"; no update after dropping 'errorBound'*) - cd "../.."; -"**** run systests complete ******************************"; -(*TODO copy the whole filestructure from sml to smltest*) - -cd"smltest/Scripts"; - use"calculate-float.sml"; - use"calculate.sml"; - use"listg.sml"; - use"rewrite.sml"; - use"scrtools.sml"; - use"term_G.sml"; - use"tools.sml"; - cd "../.."; -cd"smltest/ME"; - use"ctree.sml"; - use"calchead.sml"; - use"rewtools.sml"; - use"solve.sml"; (*detailrls can notyet ackn. 'Rewrite_Set "cancel"' *); - use"inform.sml"; - use"me.sml"; - use"ptyps.sml"; - cd "../.."; -cd"smltest/xmlsrc"; - use"datatypes.sml"; - use"pbl-met-hierarchy.sml"; - use"thy-hierarchy.sml"; - cd "../.."; -cd"smltest/FE-interface"; - use"interface.sml"; - cd "../.."; -"**** run tests on math-engine complete ******************"; -cd"smltest/IsacKnowledge"; - use"atools.sml"; - use"complex.sml"; - use"diff.sml"; - use"diffapp.sml"; - use"integrate.sml"; - use"equation.sml"; - (*use"inssort.sml"; problems with recdef in Isabelle2002*) - use"logexp.sml"; - use"poly.sml"; - use"polyminus.sml"; - use"polyeq.sml"; (*TODO 31.b, n1., 44.a, 1.a~, 1.b (all'expanded')WN - ? also check others without check 'diff.behav.'*); - use"rateq.sml"; - use"rational.sml" (*TODO add_fractions_p throws overflow-exn WN*); - use"rlang.sml"; (*WN.12.6.03: for TODOs search 'writeln', - for simplification search MG - erls: 98a(1) 104a(1) 104a(2) 68a *); - use"root.sml"; - use"rooteq.sml"; - use"rootrateq.sml"; - use"termorder.sml"; - use"trig.sml"; - use"vect.sml"; - use"wn.sml"; - use"eqsystem.sml"; - use"biegelinie.sml"; - use"algein.sml"; - cd "../.."; -"**** run tests on IsacKnowledge complete ****************"; - -val path = "/home/neuper/proto2/testsml2xml/"; -pbl_hierarchy2file (path ^ "pbl/"); -pbls2file (path ^ "pbl/"); -met_hierarchy2file (path ^ "met/"); -mets2file (path ^ "met/"); -thy_hierarchy2file (path ^ "thy/"); -thes2file (path ^ "thy/"); -"**** tested creation of xmldata *************************"; - -cd"sml"; -states:=[]; -print_depth 3; -"========================================================="; - -"**** build math-engine complete *************************"; -"**** build IsacKnowledge complete ***********************"; -"**** run systests complete ***************** re-organize!"; -"**** run tests on math-engine complete ******************"; -"**** run tests on IsacKnowledge complete ****************"; -"**** tested creation of xmldata *************************"; -"**** build isac kernel + run tests complete *************"; - - - -(**************************************************************************** -WN.notebook: SMLNJ ------------------------------------------------------------------------------ - cd ~/isabelle-smlnj/heaps/smlnj-110_x86-linux/ - sml @SMLload=02-HOL-Real-isac - cd"~/develop/sml/"; - use"ROOT.ML"; - -***************************************************************************** -WN.notebook: create HTML representation for theory files für Isac ------------------------------------------------------------------------------ -su -cd /home/neuper/proto2/isac/src/ -mv sml Isac -mv Isac/ROOT.ML Isac/ROOT.ML-save -cp Isac/RCODE-root.sml Isac/ROOT.ML -(*!!!cd"sml";!!! in ROOT.ML-save causes SysErr ("chdir failed", SOME ENOENT)*) - -/usr/local/Isabelle2002/bin/isatool usedir -i true HOL-Real /home/neuper/proto2/isac/src/Isac/ -(*^^^ does not create a new heap and writes only NEW files ... - ... to isab-installation vvv*) -cd /usr/local/Isabelle2002/browser_info/HOL/HOL-Real/ -cp -r Isac/ /home/neuper/proto2/www/kbase/thy/browser_info/HOL/HOL-Real/ - -cd /home/neuper/proto2/isac/src/ -mv Isac sml -mv sml/ROOT.ML-save sml/ROOT.ML -exit - -***************************************************************************** -save and restore contents in *.xml-files; @ stands for thy | pbl | met ------------------------------------------------------------------------------ -@> grep EXPLANATIONS *.xml > saveecex/EXPLANATIONS.tex -@> emacs saveexec/EXPLANATIONS.tex & -## there search with " " for missing lines ... -@> cd saveexec -## ... and check with ls -l file.xml -@> cd .. -@> rm *.xml ------------------------------------------------------------------------------ -export of problems and methods from sml to xml ... see below *** -restore contents in *.xml-files: ------------------------------------------------------------------------------ - - - -***************************************************************************** -export of problems and methods from sml to xml ------------------------------------------------------------------------------ -> val path = "/home/neuper/proto2/isac/xmldata/"; - -> pbl_hierarchy2file (path ^ "pbl/"); -> pbls2file (path ^ "pbl/"); - -> met_hierarchy2file (path ^ "met/"); -> mets2file (path ^ "met/"); - -> thy_hierarchy2file (path ^ "thy/"); -> thes2file (path ^ "thy/"); - -***************************************************************************** -WN.notebook: create a new heap (which is used by java in eclipse) -(PolyML overwrites HOL-Real-Isac !) ------------------------------------------------------------------------------ - su - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux - rm HOL-Real-Isac - cp HOL-Real HOL-Real-Isac - poly /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/HOL-Real-Isac - cd"/home/neuper/proto2/isac/src/sml"; use"RCODE-root.sml"; - - exit - -*****************************************************************************; -IST has another linux + polyml: create another new heap ------------------------------------------------------------------------------ -notebook:sml> scp -r ../sml wneuper@pear.ist.intra:del_graz/ - - ssh ist - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/ - rm HOL-Real-Isac - TYPE 'yes' !!! - cp HOL-Real HOL-Real-Isac - chmod u+w HOL-Real-Isac - cd ~/del_graz/sml - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac - use"RCODE-root.sml"; - - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/ - chmod u-w HOL-Real-Isac - - logout ------------------------------------------------------------------------------ -test ist> /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac -*****************************************************************************); diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/RTEST-root.sml --- a/src/Tools/isac/RTEST-root.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -(*.evaluate isac (all the code of the kernel) and isactest - (c) Walther Neuper 1997 - - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac - - /usr/local/Isabelle2002/bin/isabelle HOL-Real - cd"~/proto2/isac/src/sml"; - use"RTEST-root.sml"; - - use"ROOT.ML"; - use"RCODE-root.sml"; -.*) - -"**** run the tests **************************************"; -cd "systest"; -(*+ check kbtest/diffapp.sml for additional items in met-model*) - use"root-equ.sml"; - use"script.sml"; - (* use"script_if.sml"; WN03 missing: is_rootequation_in*) - use"scriptnew.sml"; - use"subp-rooteq.sml"; - use"tacis.sml"; - use"interface-xml.sml"; - (* use"testdaten.sml"; no update after dropping 'errorBound'*) - cd "../.."; -"**** run systests complete ******************************"; - -cd"smltest/Scripts"; - use"calculate-float.sml"; - use"calculate.sml"; - use"listg.sml"; - use"rewrite.sml"; - use"scrtools.sml"; - use"term_G.sml"; - use"tools.sml"; - cd "../.."; -cd"smltest/ME"; - use"ctree.sml"; - use"calchead.sml"; - use"rewtools.sml"; - use"solve.sml"; (*detailrls can notyet ackn. 'Rewrite_Set "cancel"' *); - use"inform.sml"; - use"me.sml"; - use"ptyps.sml"; - cd "../.."; -cd"smltest/xmlsrc"; - use"datatypes.sml"; - use"pbl-met-hierarchy.sml"; - use"thy-hierarchy.sml"; - cd "../.."; -cd"smltest/FE-interface"; - use"interface.sml"; - cd "../.."; -"**** run tests on math-engine complete ******************"; -cd"smltest/IsacKnowledge"; - use"atools.sml"; - use"complex.sml"; - use"diff.sml"; - use"diffapp.sml"; - use"integrate.sml"; - use"equation.sml"; - (*use"inssort.sml"; problems with recdef in Isabelle2002*) - use"logexp.sml"; - use"poly.sml"; - use"polyminus.sml"; - use"polyeq.sml"; (*TODO 31.b, n1., 44.a, 1.a~, 1.b (all'expanded')WN - ? also check others without check 'diff.behav.'*); - use"rateq.sml"; - use"rational.sml" (*TODO add_fractions_p throws overflow-exn WN*); - use"rlang.sml"; (*WN.12.6.03: for TODOs search 'writeln', - for simplification search MG - erls: 98a(1) 104a(1) 104a(2) 68a *); - use"root.sml"; - use"rooteq.sml"; - use"rootrateq.sml"; - use"termorder.sml"; - use"trig.sml"; - use"vect.sml"; - use"wn.sml"; - use"eqsystem.sml"; - use"biegelinie.sml"; - use"algein.sml"; - cd "../.."; -"**** run tests on IsacKnowledge complete ****************"; - -val path = "/home/neuper/proto2/testsml2xml/"; -pbl_hierarchy2file (path ^ "pbl/"); -pbls2file (path ^ "pbl/"); -met_hierarchy2file (path ^ "met/"); -mets2file (path ^ "met/"); -thy_hierarchy2file (path ^ "thy/"); -thes2file (path ^ "thy/"); -"**** tested creation of xmldata *************************"; - -cd"sml"; -states:=[]; -"========================================================="; - -"**** run systests complete ***************** re-organize!"; -"**** run tests on math-engine complete ******************"; -"**** run tests on IsacKnowledge complete ****************"; -"**** build isac kernel + run tests complete *************"; -"**** tested creation of xmldata *************************"; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/Isabelle-isac-conflicts --- a/src/Tools/isac/Scripts/Isabelle-isac-conflicts Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -6.8.02: -(1) special constants are already defined by Isabelle2002, - and thus cannot be parsed from terms; eg. - - Reals thus formula 'subproblem (Reals,...)' not possible - power thus 'Calculate power' not possible in Scripts - -(2) numerals in (terms and) thms are stored differently: - string Isabelle term isac term - 123 Bin.... Free("123",_) - 0 Const("0",_) Free("0",_) - 0 Const("1",_) Free("1",_) - -(3) overwritteln functions - find_first see isac/ROOT.ML - - -Questions for Isabelle team: - -28.02.03 -(4) what is going on in Isa02/Typefix.thy (Markus Wenzen) ? -(5) how avoid "- x" ---parse---> Free ("-x", _) ? \ No newline at end of file diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/ListG.thy --- a/src/Tools/isac/Scripts/ListG.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,204 +0,0 @@ -(* use_thy_only"../Scripts/ListG"; - use_thy_only"Scripts/ListG"; - use_thy"Scripts/ListG"; - - use_thy_only"ListG"; - W.N. 8.01 - attaches identifiers to definition of listfuns, - for storing them in list_rls - -WN.29.4.03: -*) - -theory ListG imports Complex_Main -uses ("library.sml")("calcelems.sml") -("Scripts/term_G.sml")("Scripts/calculate.sml") -("Scripts/rewrite.sml") -begin -use "library.sml" (*indent,...*) -use "calcelems.sml" (*str_of_type, Thm,...*) -use "Scripts/term_G.sml" (*num_str,...*) -use "Scripts/calculate.sml" (*???*) -use "Scripts/rewrite.sml" (*?*** At command "end" (line 205../ListG.thy*) - -text {* 'nat' in List.thy replaced by 'real' *} - -primrec length_' :: "'a list => real" -where - LENGTH_NIL: "length_' [] = 0" (*length: 'a list => nat*) -| LENGTH_CONS: "length_' (x#xs) = 1 + length_' xs" - -primrec del :: "['a list, 'a] => 'a list" -where - del_base: "del [] x = []" -| del_rec: "del (y#ys) x = (if x = y then ys else y#(del ys x))" - -definition - list_diff :: "['a list, 'a list] => 'a list" (* as -- bs *) - ("(_ --/ _)" [66, 66] 65) - where "a -- b == foldl del a b" - -consts nth_' :: "[real, 'a list] => 'a" -axioms - (*** more than one non-variable in pattern in "nth_ 1 [x] = x"--*) - NTH_NIL: "nth_' 1 (x#xs) = x" -(* NTH_CONS: "nth_' n (x#xs) = nth_' (n+ -1) xs" *) - -(*rewriter does not reach base case ...... ; - the condition involves another rule set (erls, eval_binop in Atools):*) - NTH_CONS: "1 < n ==> nth_' n (x#xs) = nth_' (n+ - 1) xs" - -(*primrec from Isabelle/src/HOL/List.thy -- def.twice not allowed*) -(*primrec*) - hd_thm: "hd(x#xs) = x" -(*primrec*) - tl_Nil: "tl([]) = []" - tl_Cons: "tl(x#xs) = xs" -(*primrec*) - null_Nil: "null([]) = True" - null_Cons: "null(x#xs) = False" -(*primrec*) - LAST: "last(x#xs) = (if xs=[] then x else last xs)" -(*primrec*) - butlast_Nil: "butlast [] = []" - butlast_Cons: "butlast(x#xs) = (if xs=[] then [] else x#butlast xs)" -(*primrec*) - mem_Nil: "x mem [] = False" - mem_Cons: "x mem (y#ys) = (if y=x then True else x mem ys)" -(*primrec-------already named--- - "set [] = {}" - "set (x#xs) = insert x (set xs)" - primrec - list_all_Nil "list_all P [] = True" - list_all_Cons "list_all P (x#xs) = (P(x) & list_all P xs)" -----------------*) -(*primrec*) - map_Nil: "map f [] = []" - map_Cons: "map f (x#xs) = f(x)#map f xs" -(*primrec*) - append_Nil: "[] @ys = ys" - append_Cons: "(x#xs)@ys = x#(xs@ys)" -(*primrec*) - rev_Nil: "rev([]) = []" - rev_Cons: "rev(x#xs) = rev(xs) @ [x]" -(*primrec*) - filter_Nil: "filter P [] = []" - filter_Cons: "filter P (x#xs) =(if P x then x#filter P xs else filter P xs)" -(*primrec-------already named--- - foldl_Nil "foldl f a [] = a" - foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs" -----------------*) -(*primrec*) - foldr_Nil: "foldr f [] a = a" - foldr_Cons: "foldr f (x#xs) a = f x (foldr f xs a)" -(*primrec*) - concat_Nil: "concat([]) = []" - concat_Cons: "concat(x#xs) = x @ concat(xs)" -(*primrec-------already named--- - drop_Nil "drop n [] = []" - drop_Cons "drop n (x#xs) = (case n of 0 => x#xs | Suc(m) => drop m xs)" - (* Warning: simpset does not contain this definition but separate theorems - for n=0 / n=Suc k*) -(*primrec*) - take_Nil "take n [] = []" - take_Cons "take n (x#xs) = (case n of 0 => [] | Suc(m) => x # take m xs)" - (* Warning: simpset does not contain this definition but separate theorems - for n=0 / n=Suc k*) -(*primrec*) - nth_Cons "(x#xs)!n = (case n of 0 => x | (Suc k) => xs!k)" - (* Warning: simpset does not contain this definition but separate theorems - for n=0 / n=Suc k*) -(*primrec*) - " [][i:=v] = []" - "(x#xs)[i:=v] = (case i of 0 => v # xs - | Suc j => x # xs[j:=v])" -----------------*) -(*primrec*) - takeWhile_Nil: "takeWhile P [] = []" - takeWhile_Cons: - "takeWhile P (x#xs) = (if P x then x#takeWhile P xs else [])" -(*primrec*) - dropWhile_Nil: "dropWhile P [] = []" - dropWhile_Cons: - "dropWhile P (x#xs) = (if P x then dropWhile P xs else x#xs)" -(*primrec*) - zip_Nil: "zip xs [] = []" - zip_Cons: "zip xs (y#ys) =(case xs of [] => [] | z#zs =>(z,y)#zip zs ys)" - (* Warning: simpset does not contain this definition but separate theorems - for xs=[] / xs=z#zs *) -(*primrec - upt_0 "[i..0(] = []" - upt_Suc "[i..(Suc j)(] = (if i <= j then [i..j(] @ [j] else [])" -*) -(*primrec*) - distinct_Nil: "distinct [] = True" - distinct_Cons: "distinct (x#xs) = (x ~: set xs & distinct xs)" -(*primrec*) - remdups_Nil: "remdups [] = []" - remdups_Cons: "remdups (x#xs) = - (if x : set xs then remdups xs else x # remdups xs)" -(*primrec-------already named--- - replicate_0 "replicate 0 x = []" - replicate_Suc "replicate (Suc n) x = x # replicate n x" -----------------*) - -(** Lexicographic orderings on lists ...!!!**) - -ML{* (*the former ListG.ML*) -(** rule set for evaluating listexpr in scripts **) -val list_rls = - Rls{id="list_rls",preconds = [], rew_ord = ("dummy_ord",dummy_ord), - erls = e_rls, srls = Erls, calc = [], (*asm_thm=[],*) - rules = (*8.01: copied from*) - [Thm ("refl", num_str refl), (*'a<>b -> FALSE' by fun eval_equal*) - Thm ("o_apply", num_str @{thm o_apply}), - - Thm ("NTH_CONS",num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*) - Thm ("NTH_NIL",num_str @{thm NTH_NIL}), - Thm ("append_Cons",num_str @{thm append_Cons}), - Thm ("append_Nil",num_str @{thm append_Nil}), - Thm ("butlast_Cons",num_str @{thm butlast_Cons}), - Thm ("butlast_Nil",num_str @{thm butlast_Nil}), - Thm ("concat_Cons",num_str @{thm concat_Cons}), - Thm ("concat_Nil",num_str @{thm concat_Nil}), - Thm ("del_base",num_str @{thm del_base}), - Thm ("del_rec",num_str @{thm del_rec}), - - Thm ("distinct_Cons",num_str @{thm distinct_Cons}), - Thm ("distinct_Nil",num_str @{thm distinct_Nil}), - Thm ("dropWhile_Cons",num_str @{thm dropWhile_Cons}), - Thm ("dropWhile_Nil",num_str @{thm dropWhile_Nil}), - Thm ("filter_Cons",num_str @{thm filter_Cons}), - Thm ("filter_Nil",num_str @{thm filter_Nil}), - Thm ("foldr_Cons",num_str @{thm foldr_Cons}), - Thm ("foldr_Nil",num_str @{thm foldr_Nil}), - Thm ("hd_thm",num_str @{thm hd_thm}), - Thm ("LAST",num_str @{thm LAST}), - Thm ("LENGTH_CONS",num_str @{thm LENGTH_CONS}), - Thm ("LENGTH_NIL",num_str @{thm LENGTH_NIL}), - Thm ("list_diff_def",num_str @{thm list_diff_def}), - Thm ("map_Cons",num_str @{thm map_Cons}), - Thm ("map_Nil",num_str @{thm map_Cons}), - Thm ("mem_Cons",num_str @{thm mem_Cons}), - Thm ("mem_Nil",num_str @{thm mem_Nil}), - Thm ("null_Cons",num_str @{thm null_Cons}), - Thm ("null_Nil",num_str @{thm null_Nil}), - Thm ("remdups_Cons",num_str @{thm remdups_Cons}), - Thm ("remdups_Nil",num_str @{thm remdups_Nil}), - Thm ("rev_Cons",num_str @{thm rev_Cons}), - Thm ("rev_Nil",num_str @{thm rev_Nil}), - Thm ("take_Nil",num_str @{thm take_Nil}), - Thm ("take_Cons",num_str @{thm take_Cons}), - Thm ("tl_Cons",num_str @{thm tl_Cons}), - Thm ("tl_Nil",num_str @{thm tl_Nil}), - Thm ("zip_Cons",num_str @{thm zip_Cons}), - Thm ("zip_Nil",num_str @{thm zip_Nil}) - ], scr = EmptyScr}:rls; -*} - -ML{* -ruleset' := overwritelthy @{theory} (!ruleset', - [("list_rls",list_rls) - ]); -*} -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/Real2002-theorems.sml --- a/src/Tools/isac/Scripts/Real2002-theorems.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1005 +0,0 @@ -(*WN060306 from isabelle-users: -put expressions involving plus and minus into a canonical form. Here is a possible set of -rules: - - add_assoc add_commute - diff_def minus_add_distrib - minus_minus minus_zero -===========================================================================*) - -(* - cd ~/Isabelle2002/src/HOL/Real - grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml - WN 9.8.02 - -ML> thy; -val it = - {ProtoPure, CPure, HOL, Set, Typedef, Fun, Product_Type, Lfp, Gfp, Sum_Type, - Relation, Record, Inductive, Transitive_Closure, Wellfounded_Recursion, - NatDef, Nat, NatArith, Divides, Power, SetInterval, Finite_Set, Equiv, - IntDef, Int, Datatype_Universe, Datatype, Numeral, Bin, IntArith, - Wellfounded_Relations, Recdef, IntDiv, IntPower, NatBin, NatSimprocs, - Relation_Power, PreList, List, Map, Hilbert_Choice, Main, Lubs, PNat, PRat, - PReal, RealDef, RealOrd, RealInt, RealBin, RealArith0, RealArith, - RComplete, RealAbs, RealPow, Ring_and_Field, Complex_Numbers, Real} - : theory - -theories with their respective theorems found by -grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml; -theories listed in the the order as found in Real.thy above - -comments - (**)"...theorem..." : first choice for one of the rule-sets - "...theorem..."(*??*): to be investigated - "...theorem... : just for documenting the contents -*) - -Lubs.ML:qed ----------------------------------------------------------------- - "setleI"; "ALL y::?'a:?S::?'a set. y <= (?x::?'a) ==> ?S *<= ?x" - "setleD"; "[| (?S::?'a set) *<= (?x::?'a); (?y::?'a) : ?S |] ==> ?y <= ?x" - "setgeI"; "Ball (?S::?'a set) (op <= (?x::?'a)) ==> ?x <=* ?S" - "setgeD"; "[| (?x::?'a) <=* (?S::?'a set); (?y::?'a) : ?S |] ==> ?x <= ?y" - "leastPD1"; - "leastPD2"; - "leastPD3"; - "isLubD1"; - "isLubD1a"; - "isLub_isUb"; - "isLubD2"; - "isLubD3"; - "isLubI1"; - "isLubI2"; - "isUbD"; - "[| isUb (?R::?'a set) (?S::?'a set) (?x::?'a); (?y::?'a) : ?S |] - ==> ?y <= ?x" "isUbD2"; - "isUbD2a"; - "isUbI"; - "isLub_le_isUb"; - "isLub_ubs"; -PNat.ML:qed ------------------------------------------------------------------ - "pnat_fun_mono"; "mono (%X::nat set. {Suc (0::nat)} Un Suc ` X)" - "one_RepI"; "Suc (0::nat) : pnat" - "pnat_Suc_RepI"; - "two_RepI"; - "PNat_induct"; - "[| (?i::nat) : pnat; (?P::nat => bool) (Suc (0::nat)); - !!j::nat. [| j : pnat; ?P j |] ==> ?P (Suc j) |] ==> ?P ?i" - "pnat_induct"; - "[| (?P::pnat => bool) (1::pnat); !!n::pnat. ?P n ==> ?P (pSuc n) |] - ==> ?P (?n::pnat)" - "pnat_diff_induct"; - "pnatE"; - "inj_on_Abs_pnat"; - "inj_Rep_pnat"; - "zero_not_mem_pnat"; - "mem_pnat_gt_zero"; - "gt_0_mem_pnat"; - "mem_pnat_gt_0_iff"; - "Rep_pnat_gt_zero"; - "pnat_add_commute"; "(?x::pnat) + (?y::pnat) = ?y + ?x" - "Collect_pnat_gt_0"; - "pSuc_not_one"; - "inj_pSuc"; - "pSuc_pSuc_eq"; - "n_not_pSuc_n"; - "not1_implies_pSuc"; - "pSuc_is_plus_one"; - "sum_Rep_pnat"; - "sum_Rep_pnat_sum"; - "pnat_add_assoc"; - "pnat_add_left_commute"; - "pnat_add_left_cancel"; - "pnat_add_right_cancel"; - "pnat_no_add_ident"; - "pnat_less_not_refl"; - "pnat_less_not_refl2"; - "Rep_pnat_not_less0"; - "Rep_pnat_not_less_one"; - "Rep_pnat_gt_implies_not0"; - "pnat_less_linear"; - "Rep_pnat_le_one"; - "lemma_less_ex_sum_Rep_pnat"; - "pnat_le_iff_Rep_pnat_le"; - "pnat_add_left_cancel_le"; - "pnat_add_left_cancel_less"; - "pnat_add_lessD1"; - "pnat_not_add_less1"; - "pnat_not_add_less2"; -PNat.ML:qed_spec_mp - "pnat_add_leD1"; - "pnat_add_leD2"; -PNat.ML:qed - "pnat_less_add_eq_less"; - "pnat_less_iff"; - "pnat_linear_Ex_eq"; - "pnat_eq_lessI"; - "Rep_pnat_mult_1"; - "Rep_pnat_mult_1_right"; - "mult_Rep_pnat"; - "mult_Rep_pnat_mult"; - "pnat_mult_commute"; "(?m::pnat) * (?n::pnat) = ?n * ?m" - "pnat_add_mult_distrib"; - "pnat_add_mult_distrib2"; - "pnat_mult_assoc"; - "pnat_mult_left_commute"; - "pnat_mult_1"; - "pnat_mult_1_left"; - "pnat_mult_less_mono2"; - "pnat_mult_less_mono1"; - "pnat_mult_less_cancel2"; - "pnat_mult_less_cancel1"; - "pnat_mult_cancel2"; - "pnat_mult_cancel1"; - "pnat_same_multI2"; - "eq_Abs_pnat"; - "pnat_one_iff"; - "pnat_two_eq"; - "inj_pnat_of_nat"; - "nat_add_one_less"; - "nat_add_one_less1"; - "pnat_of_nat_add"; - "pnat_of_nat_less_iff"; - "pnat_of_nat_mult"; -PRat.ML:qed ------------------------------------------------------------------ - "prat_trans_lemma"; - "[| (?x1.0::pnat) * (?y2.0::pnat) = (?x2.0::pnat) * (?y1.0::pnat); - ?x2.0 * (?y3.0::pnat) = (?x3.0::pnat) * ?y2.0 |] - ==> ?x1.0 * ?y3.0 = ?x3.0 * ?y1.0" - "ratrel_iff"; - "ratrelI"; - "ratrelE_lemma"; - "ratrelE"; - "ratrel_refl"; - "equiv_ratrel"; - "ratrel_in_prat"; - "inj_on_Abs_prat"; - "inj_Rep_prat"; - "inj_prat_of_pnat"; - "eq_Abs_prat"; - "qinv_congruent"; - "qinv"; - "qinv_qinv"; - "inj_qinv"; - "qinv_1"; - "prat_add_congruent2_lemma"; - "prat_add_congruent2"; - "prat_add"; - "prat_add_commute"; - "prat_add_assoc"; - "prat_add_left_commute"; - "pnat_mult_congruent2"; - "prat_mult"; - "prat_mult_commute"; - "prat_mult_assoc"; - "prat_mult_left_commute"; - "prat_mult_1"; - "prat_mult_1_right"; - "prat_of_pnat_add"; - "prat_of_pnat_mult"; - "prat_mult_qinv"; - "prat_mult_qinv_right"; - "prat_qinv_ex"; - "prat_qinv_ex1"; - "prat_qinv_left_ex1"; - "prat_mult_inv_qinv"; - "prat_as_inverse_ex"; - "qinv_mult_eq"; - "prat_add_mult_distrib"; - "prat_add_mult_distrib2"; - "prat_less_iff"; - "prat_lessI"; - "prat_lessE_lemma"; - "prat_lessE"; - "prat_less_trans"; - "prat_less_not_refl"; - "prat_less_not_sym"; - "lemma_prat_dense"; - "prat_lemma_dense"; - "prat_dense"; - "prat_add_less2_mono1"; - "prat_add_less2_mono2"; - "prat_mult_less2_mono1"; - "prat_mult_left_less2_mono1"; - "lemma_prat_add_mult_mono"; - "qless_Ex"; - "lemma_prat_less_linear"; - "prat_linear"; - "prat_linear_less2"; - "lemma1_qinv_prat_less"; - "lemma2_qinv_prat_less"; - "qinv_prat_less"; - "prat_qinv_gt_1"; - "prat_qinv_is_gt_1"; - "prat_less_1_2"; - "prat_less_qinv_2_1"; - "prat_mult_qinv_less_1"; - "prat_self_less_add_self"; - "prat_self_less_add_right"; - "prat_self_less_add_left"; - "prat_self_less_mult_right"; - "prat_leI"; - "prat_leD"; - "prat_less_le_iff"; - "not_prat_leE"; - "prat_less_imp_le"; - "prat_le_imp_less_or_eq"; - "prat_less_or_eq_imp_le"; - "prat_le_eq_less_or_eq"; - "prat_le_refl"; - "prat_le_less_trans"; - "prat_le_trans"; - "not_less_not_eq_prat_less"; - "prat_add_less_mono"; - "prat_mult_less_mono"; - "prat_mult_left_le2_mono1"; - "prat_mult_le2_mono1"; - "qinv_prat_le"; - "prat_add_left_le2_mono1"; - "prat_add_le2_mono1"; - "prat_add_le_mono"; - "prat_add_right_less_cancel"; - "prat_add_left_less_cancel"; - "Abs_prat_mult_qinv"; - "lemma_Abs_prat_le1"; - "lemma_Abs_prat_le2"; - "lemma_Abs_prat_le3"; - "pre_lemma_gleason9_34"; - "pre_lemma_gleason9_34b"; - "prat_of_pnat_less_iff"; - "lemma_prat_less_1_memEx"; - "lemma_prat_less_1_set_non_empty"; - "empty_set_psubset_lemma_prat_less_1_set"; - "lemma_prat_less_1_not_memEx"; - "lemma_prat_less_1_set_not_rat_set"; - "lemma_prat_less_1_set_psubset_rat_set"; - "preal_1"; - "{x::prat. x < prat_of_pnat (Abs_pnat (Suc (0::nat)))} - : {A::prat set. - {} < A & - A < UNIV & - (ALL y::prat:A. (ALL z::prat. z < y --> z : A) & Bex A (op < y))}" -PReal.ML:qed ----------------------------------------------------------------- - "inj_on_Abs_preal"; "inj_on Abs_preal preal" - "inj_Rep_preal"; - "empty_not_mem_preal"; - "one_set_mem_preal"; - "preal_psubset_empty"; - "Rep_preal_psubset_empty"; - "mem_Rep_preal_Ex"; - "prealI1"; - "[| {} < (?A::prat set); ?A < UNIV; - ALL y::prat:?A. (ALL z::prat. z < y --> z : ?A) & Bex ?A (op < y) |] - ==> ?A : preal" - "prealI2"; - "prealE_lemma"; - "prealE_lemma1"; - "prealE_lemma2"; - "prealE_lemma3"; - "prealE_lemma3a"; - "prealE_lemma3b"; - "prealE_lemma4"; - "prealE_lemma4a"; - "not_mem_Rep_preal_Ex"; - "lemma_prat_less_set_mem_preal"; - "lemma_prat_set_eq"; - "inj_preal_of_prat"; - "not_in_preal_ub"; - "preal_less_not_refl"; - "preal_not_refl2"; - "preal_less_trans"; - "preal_less_not_sym"; - "preal_linear"; - "(?r1.0::preal) < (?r2.0::preal) | ?r1.0 = ?r2.0 | ?r2.0 < ?r1.0" - "preal_linear_less2"; - "preal_add_commute"; "(?x::preal) + (?y::preal) = ?y + ?x" - "preal_add_set_not_empty"; - "preal_not_mem_add_set_Ex"; - "preal_add_set_not_prat_set"; - "preal_add_set_lemma3"; - "preal_add_set_lemma4"; - "preal_mem_add_set"; - "preal_add_assoc"; - "preal_add_left_commute"; - "preal_mult_commute"; "(?x::preal) * (?y::preal) = ?y * ?x" - "preal_mult_set_not_empty"; - "preal_not_mem_mult_set_Ex"; - "preal_mult_set_not_prat_set"; - "preal_mult_set_lemma3"; - "preal_mult_set_lemma4"; - "preal_mem_mult_set"; - "preal_mult_assoc"; - "preal_mult_left_commute"; - "preal_mult_1"; - "preal_mult_1_right"; - "preal_add_assoc_cong"; - "preal_add_assoc_swap"; - "mem_Rep_preal_addD"; - "mem_Rep_preal_addI"; - "mem_Rep_preal_add_iff"; - "mem_Rep_preal_multD"; - "mem_Rep_preal_multI"; - "mem_Rep_preal_mult_iff"; - "lemma_add_mult_mem_Rep_preal"; - "lemma_add_mult_mem_Rep_preal1"; - "lemma_preal_add_mult_distrib"; - "lemma_preal_add_mult_distrib2"; - "preal_add_mult_distrib2"; - "preal_add_mult_distrib"; - "qinv_not_mem_Rep_preal_Ex"; - "lemma_preal_mem_inv_set_ex"; - "preal_inv_set_not_empty"; - "qinv_mem_Rep_preal_Ex"; - "preal_not_mem_inv_set_Ex"; - "preal_inv_set_not_prat_set"; - "preal_inv_set_lemma3"; - "preal_inv_set_lemma4"; - "preal_mem_inv_set"; - "preal_mem_mult_invD"; - "lemma1_gleason9_34"; - "lemma1b_gleason9_34"; - "lemma_gleason9_34a"; - "lemma_gleason9_34"; - "lemma1_gleason9_36"; - "lemma2_gleason9_36"; - "lemma_gleason9_36"; - "lemma_gleason9_36a"; - "preal_mem_mult_invI"; - "preal_mult_inv"; - "preal_mult_inv_right"; - "eq_Abs_preal"; - "Rep_preal_self_subset"; - "Rep_preal_sum_not_subset"; - "Rep_preal_sum_not_eq"; - "preal_self_less_add_left"; - "preal_self_less_add_right"; - "preal_leD"; - "not_preal_leE"; - "preal_leI"; - "preal_less_le_iff"; - "preal_less_imp_le"; - "preal_le_imp_less_or_eq"; - "preal_less_or_eq_imp_le"; - "preal_le_refl"; - "preal_le_trans"; - "preal_le_anti_sym"; - "preal_neq_iff"; - "preal_less_le"; - "lemma_psubset_mem"; - "lemma_psubset_not_refl"; - "psubset_trans"; - "subset_psubset_trans"; - "subset_psubset_trans2"; - "psubsetD"; - "lemma_ex_mem_less_left_add1"; - "preal_less_set_not_empty"; - "lemma_ex_not_mem_less_left_add1"; - "preal_less_set_not_prat_set"; - "preal_less_set_lemma3"; - "preal_less_set_lemma4"; - "preal_mem_less_set"; - "preal_less_add_left_subsetI"; - "lemma_sum_mem_Rep_preal_ex"; - "preal_less_add_left_subsetI2"; - "preal_less_add_left"; - "preal_less_add_left_Ex"; - "preal_add_less2_mono1"; - "preal_add_less2_mono2"; - "preal_mult_less_mono1"; - "preal_mult_left_less_mono1"; - "preal_mult_left_le_mono1"; - "preal_mult_le_mono1"; - "preal_add_left_le_mono1"; - "preal_add_le_mono1"; - "preal_add_right_less_cancel"; - "preal_add_left_less_cancel"; - "preal_add_less_iff1"; - "preal_add_less_iff2"; - "preal_add_less_mono"; - "preal_mult_less_mono"; - "preal_add_right_cancel"; - "preal_add_left_cancel"; - "preal_add_left_cancel_iff"; - "preal_add_right_cancel_iff"; - "preal_sup_mem_Ex"; - "preal_sup_set_not_empty"; - "preal_sup_not_mem_Ex"; - "preal_sup_not_mem_Ex1"; - "preal_sup_set_not_prat_set"; - "preal_sup_set_not_prat_set1"; - "preal_sup_set_lemma3"; - "preal_sup_set_lemma3_1"; - "preal_sup_set_lemma4"; - "preal_sup_set_lemma4_1"; - "preal_sup"; - "preal_sup1"; - "preal_psup_leI"; - "preal_psup_leI2"; - "preal_psup_leI2b"; - "preal_psup_leI2a"; - "psup_le_ub"; - "psup_le_ub1"; - "preal_complete"; - "lemma_preal_rat_less"; - "lemma_preal_rat_less2"; - "preal_of_prat_add"; - "lemma_preal_rat_less3"; - "lemma_preal_rat_less4"; - "preal_of_prat_mult"; - "preal_of_prat_less_iff"; "(preal_of_prat ?p < preal_of_prat ?q) = (?p < ?q)" -RealDef.ML:qed --------------------------------------------------------------- - "preal_trans_lemma"; - "realrel_iff"; - "realrelI"; - "?x1.0 + ?y2.0 = ?x2.0 + ?y1.0 ==> ((?x1.0, ?y1.0), ?x2.0, ?y2.0) : realrel" - "realrelE_lemma"; - "realrelE"; - "realrel_refl"; - "equiv_realrel"; - "realrel_in_real"; - "inj_on_Abs_REAL"; - "inj_Rep_REAL"; - "inj_real_of_preal"; - "eq_Abs_REAL"; - "real_minus_congruent"; - "real_minus"; - "- Abs_REAL (realrel `` {(?x, ?y)}) = Abs_REAL (realrel `` {(?y, ?x)})" - "real_minus_minus"; (**)"- (- (?z::real)) = ?z" - "inj_real_minus"; "inj uminus" - "real_minus_zero"; (**)"- 0 = 0" - "real_minus_zero_iff"; (**)"(- ?x = 0) = (?x = 0)" - "real_add_congruent2"; - "congruent2 realrel - (%p1 p2. (%(x1, y1). (%(x2, y2). realrel `` {(x1 + x2, y1 + y2)}) p2) p1)" - "real_add"; - "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) + - Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) = - Abs_REAL (realrel `` {(?x1.0 + ?x2.0, ?y1.0 + ?y2.0)})" - "real_add_commute"; (**)"(?z::real) + (?w::real) = ?w + ?z" - "real_add_assoc"; (**) - "real_add_left_commute"; (**) - "real_add_zero_left"; (**)"0 + ?z = ?z" - "real_add_zero_right"; (**) - "real_add_minus"; (**)"?z + - ?z = 0" - "real_add_minus_left"; (**) - "real_add_minus_cancel"; (**)"?z + (- ?z + ?w) = ?w" - "real_minus_add_cancel"; (**)"- ?z + (?z + ?w) = ?w" - "real_minus_ex"; "EX y. ?x + y = 0" - "real_minus_ex1"; - "real_minus_left_ex1"; "EX! y. y + ?x = 0" - "real_add_minus_eq_minus";"?x + ?y = 0 ==> ?x = - ?y" - "real_as_add_inverse_ex"; "EX y. ?x = - y" - "real_minus_add_distrib"; (**)"- (?x + ?y) = - ?x + - ?y" - "real_add_left_cancel"; "(?x + ?y = ?x + ?z) = (?y = ?z)" - "real_add_right_cancel"; "(?y + ?x = ?z + ?x) = (?y = ?z)" - "real_diff_0"; (**)"0 - ?x = - ?x" - "real_diff_0_right"; (**)"?x - 0 = ?x" - "real_diff_self"; (**)"?x - ?x = 0" - "real_mult_congruent2_lemma"; - "real_mult_congruent2"; - "congruent2 realrel - (%p1 p2. - (%(x1, y1). - (%(x2, y2). realrel `` {(x1 * x2 + y1 * y2, x1 * y2 + x2 * y1)}) - p2) p1)" - "real_mult"; - "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) * - Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) = - Abs_REAL - (realrel `` - {(?x1.0 * ?x2.0 + ?y1.0 * ?y2.0, ?x1.0 * ?y2.0 + ?x2.0 * ?y1.0)})" - "real_mult_commute"; (**)"?z * ?w = ?w * ?z" - "real_mult_assoc"; (**) - "real_mult_left_commute"; - (**)"?z1.0 * (?z2.0 * ?z3.0) = ?z2.0 * (?z1.0 * ?z3.0)" - "real_mult_1"; (**)"1 * ?z = ?z" - "real_mult_1_right"; (**)"?z * 1 = ?z" - "real_mult_0"; (**) - "real_mult_0_right"; (**)"?z * 0 = 0" - "real_mult_minus_eq1"; (**)"- ?x * ?y = - (?x * ?y)" - "real_mult_minus_eq2"; (**)"?x * - ?y = - (?x * ?y)" - "real_mult_minus_1"; (**)"- 1 * ?z = - ?z" - "real_mult_minus_1_right";(**)"?z * - 1 = - ?z" - "real_minus_mult_cancel"; (**)"- ?x * - ?y = ?x * ?y" - "real_minus_mult_commute";(**)"- ?x * ?y = ?x * - ?y" - "real_add_assoc_cong"; - "?z + ?v = ?z' + ?v' ==> ?z + (?v + ?w) = ?z' + (?v' + ?w)" - "real_add_assoc_swap"; (**)"?z + (?v + ?w) = ?v + (?z + ?w)" - "real_add_mult_distrib"; (**)"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w" - "real_add_mult_distrib2"; (**)"?w * (?z1.0 + ?z2.0) = ?w * ?z1.0 + ?w * ?z2.0" - "real_diff_mult_distrib"; (**)"(?z1.0 - ?z2.0) * ?w = ?z1.0 * ?w - ?z2.0 * ?w" - "real_diff_mult_distrib2";(**)"?w * (?z1.0 - ?z2.0) = ?w * ?z1.0 - ?w * ?z2.0" - "real_zero_not_eq_one"; - "real_zero_iff"; "0 = Abs_REAL (realrel `` {(?x, ?x)})" - "real_mult_inv_right_ex"; "?x ~= 0 ==> EX y. ?x * y = 1" - "real_mult_inv_left_ex"; "?x ~= 0 ==> inverse ?x * ?x = 1" - "real_mult_inv_left"; - "real_mult_inv_right"; "?x ~= 0 ==> ?x * inverse ?x = 1" - "INVERSE_ZERO"; "inverse 0 = 0" - "DIVISION_BY_ZERO"; (*NOT for adding to default simpset*)"?a / 0 = 0" - "real_mult_left_cancel"; (**)"?c ~= 0 ==> (?c * ?a = ?c * ?b) = (?a = ?b)" - "real_mult_right_cancel"; (**)"?c ~= 0 ==> (?a * ?c = ?b * ?c) = (?a = ?b)" - "real_mult_left_cancel_ccontr"; "?c * ?a ~= ?c * ?b ==> ?a ~= ?b" - "real_mult_right_cancel_ccontr"; "?a * ?c ~= ?b * ?c ==> ?a ~= ?b" - "real_inverse_not_zero"; "?x ~= 0 ==> inverse ?x ~= 0" - "real_mult_not_zero"; "[| ?x ~= 0; ?y ~= 0 |] ==> ?x * ?y ~= 0" - "real_inverse_inverse"; "inverse (inverse ?x) = ?x" - "real_inverse_1"; "inverse 1 = 1" - "real_minus_inverse"; "inverse (- ?x) = - inverse ?x" - "real_inverse_distrib"; "inverse (?x * ?y) = inverse ?x * inverse ?y" - "real_times_divide1_eq"; (**)"?x * (?y / ?z) = ?x * ?y / ?z" - "real_times_divide2_eq"; (**)"?y / ?z * ?x = ?y * ?x / ?z" - "real_divide_divide1_eq"; (**)"?x / (?y / ?z) = ?x * ?z / ?y" - "real_divide_divide2_eq"; (**)"?x / ?y / ?z = ?x / (?y * ?z)" - "real_minus_divide_eq"; (**)"- ?x / ?y = - (?x / ?y)" - "real_divide_minus_eq"; (**)"?x / - ?y = - (?x / ?y)" - "real_add_divide_distrib"; (**)"(?x + ?y) / ?z = ?x / ?z + ?y / ?z" - "preal_lemma_eq_rev_sum"; - "[| ?x = ?y; ?x1.0 = ?y1.0 |] ==> ?x + ?y1.0 = ?x1.0 + ?y" - "preal_add_left_commute_cancel"; - "?x + (?b + ?y) = ?x1.0 + (?b + ?y1.0) ==> ?x + ?y = ?x1.0 + ?y1.0" - "preal_lemma_for_not_refl"; - "real_less_not_refl"; "~ ?R < ?R" - "real_not_refl2"; - "preal_lemma_trans"; - "real_less_trans"; - "real_less_not_sym"; - "real_of_preal_add"; - "real_of_preal (?z1.0 + ?z2.0) = real_of_preal ?z1.0 + real_of_preal ?z2.0" - "real_of_preal_mult"; - "real_of_preal_ExI"; - "real_of_preal_ExD"; - "real_of_preal_iff"; - "real_of_preal_trichotomy"; - "real_of_preal_trichotomyE"; - "real_of_preal_lessD"; - "real_of_preal_lessI"; - "?m1.0 < ?m2.0 ==> real_of_preal ?m1.0 < real_of_preal ?m2.0" - "real_of_preal_less_iff1"; - "real_of_preal_minus_less_self"; - "real_of_preal_minus_less_zero"; - "real_of_preal_not_minus_gt_zero"; - "real_of_preal_zero_less"; - "real_of_preal_not_less_zero"; - "real_minus_minus_zero_less"; - "real_of_preal_sum_zero_less"; - "real_of_preal_minus_less_all"; - "real_of_preal_not_minus_gt_all"; - "real_of_preal_minus_less_rev1"; - "real_of_preal_minus_less_rev2"; - "real_of_preal_minus_less_rev_iff"; - "real_linear"; "?R1.0 < ?R2.0 | ?R1.0 = ?R2.0 | ?R2.0 < ?R1.0" - "real_neq_iff"; - "real_linear_less2"; - "[| ?R1.0 < ?R2.0 ==> ?P; ?R1.0 = ?R2.0 ==> ?P; ?R2.0 < ?R1.0 ==> ?P |] - ==> ?P" - "real_leI"; - "real_leD"; "~ ?w < ?z ==> ?z <= ?w" - "real_less_le_iff"; - "not_real_leE"; - "real_le_imp_less_or_eq"; - "real_less_or_eq_imp_le"; - "real_le_less"; - "real_le_refl"; "?w <= ?w" - "real_le_linear"; - "real_le_trans"; "[| ?i <= ?j; ?j <= ?k |] ==> ?i <= ?k" - "real_le_anti_sym"; "[| ?z <= ?w; ?w <= ?z |] ==> ?z = ?w" - "not_less_not_eq_real_less"; - "real_less_le"; "(?w < ?z) = (?w <= ?z & ?w ~= ?z)" - "real_minus_zero_less_iff"; - "real_minus_zero_less_iff2"; - "real_less_add_positive_left_Ex"; - "real_less_sum_gt_zero"; "?W < ?S ==> 0 < ?S + - ?W" - "real_lemma_change_eq_subj"; - "real_sum_gt_zero_less"; "0 < ?S + - ?W ==> ?W < ?S" - "real_less_sum_gt_0_iff"; "(0 < ?S + - ?W) = (?W < ?S)" - "real_less_eq_diff"; "(?x < ?y) = (?x - ?y < 0)" - "real_add_diff_eq"; (**)"?x + (?y - ?z) = ?x + ?y - ?z" - "real_diff_add_eq"; (**)"?x - ?y + ?z = ?x + ?z - ?y" - "real_diff_diff_eq"; (**)"?x - ?y - ?z = ?x - (?y + ?z)" - "real_diff_diff_eq2"; (**)"?x - (?y - ?z) = ?x + ?z - ?y" - "real_diff_less_eq"; "(?x - ?y < ?z) = (?x < ?z + ?y)" - "real_less_diff_eq"; - "real_diff_le_eq"; "(?x - ?y <= ?z) = (?x <= ?z + ?y)" - "real_le_diff_eq"; - "real_diff_eq_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)" - "real_eq_diff_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)" - "real_less_eqI"; - "real_le_eqI"; - "real_eq_eqI"; "?x - ?y = ?x' - ?y' ==> (?x = ?y) = (?x' = ?y')" -RealOrd.ML:qed --------------------------------------------------------------- - "real_add_cancel_21"; "(?x + (?y + ?z) = ?y + ?u) = (?x + ?z = ?u)" - "real_add_cancel_end"; "(?x + (?y + ?z) = ?y) = (?x = - ?z)" - "real_minus_diff_eq"; (*??*)"- (?x - ?y) = ?y - ?x" - "real_gt_zero_preal_Ex"; - "real_gt_preal_preal_Ex"; - "real_ge_preal_preal_Ex"; - "real_less_all_preal"; "?y <= 0 ==> ALL x. ?y < real_of_preal x" - "real_less_all_real2"; - "real_lemma_add_positive_imp_less"; - "real_ex_add_positive_left_less";"EX T. 0 < T & ?R + T = ?S ==> ?R < ?S" - "real_less_iff_add"; - "real_of_preal_le_iff"; - "real_mult_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x * ?y" - "neg_real_mult_order"; - "real_mult_less_0"; "[| 0 < ?x; ?y < 0 |] ==> ?x * ?y < 0" - "real_zero_less_one"; "0 < 1" - "real_add_right_cancel_less"; "(?v + ?z < ?w + ?z) = (?v < ?w)" - "real_add_left_cancel_less"; - "real_add_right_cancel_le"; - "real_add_left_cancel_le"; - "real_add_less_le_mono"; "[| ?w' < ?w; ?z' <= ?z |] ==> ?w' + ?z' < ?w + ?z" - "real_add_le_less_mono"; "[| ?w' <= ?w; ?z' < ?z |] ==> ?w' + ?z' < ?w + ?z" - "real_add_less_mono2"; - "real_less_add_right_cancel"; - "real_less_add_left_cancel"; "?C + ?A < ?C + ?B ==> ?A < ?B" - "real_le_add_right_cancel"; - "real_le_add_left_cancel"; "?C + ?A <= ?C + ?B ==> ?A <= ?B" - "real_add_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x + ?y" - "real_le_add_order"; - "real_add_less_mono"; - "real_add_left_le_mono1"; - "real_add_le_mono"; - "real_less_Ex"; - "real_add_minus_positive_less_self"; "0 < ?r ==> ?u + - ?r < ?u" - "real_le_minus_iff"; "(- ?s <= - ?r) = (?r <= ?s)" - "real_le_square"; - "real_of_posnat_one"; - "real_of_posnat_two"; - "real_of_posnat_add"; "real_of_posnat ?n1.0 + real_of_posnat ?n2.0 = - real_of_posnat (?n1.0 + ?n2.0) + 1" - "real_of_posnat_add_one"; - "real_of_posnat_Suc"; - "inj_real_of_posnat"; - "real_of_nat_zero"; - "real_of_nat_one"; "real (Suc 0) = 1" - "real_of_nat_add"; - "real_of_nat_Suc"; - "real_of_nat_less_iff"; - "real_of_nat_le_iff"; - "inj_real_of_nat"; - "real_of_nat_ge_zero"; - "real_of_nat_mult"; - "real_of_nat_inject"; -RealOrd.ML:qed_spec_mp - "real_of_nat_diff"; -RealOrd.ML:qed - "real_of_nat_zero_iff"; - "real_of_nat_neg_int"; - "real_inverse_gt_0"; - "real_inverse_less_0"; - "real_mult_less_mono1"; - "real_mult_less_mono2"; - "real_mult_less_cancel1"; - "(?k * ?m < ?k * ?n) = (0 < ?k & ?m < ?n | ?k < 0 & ?n < ?m)" - "real_mult_less_cancel2"; - "real_mult_less_iff1"; - "real_mult_less_iff2"; - "real_mult_le_cancel_iff1"; - "real_mult_le_cancel_iff2"; - "real_mult_le_less_mono1"; - "real_mult_less_mono"; - "real_mult_less_mono'"; - "real_gt_zero"; "1 <= ?x ==> 0 < ?x" - "real_mult_self_le"; "[| 1 < ?r; 1 <= ?x |] ==> ?x <= ?r * ?x" - "real_mult_self_le2"; - "real_inverse_less_swap"; - "real_mult_is_0"; - "real_inverse_add"; - "real_minus_zero_le_iff"; - "real_minus_zero_le_iff2"; - "real_sum_squares_cancel"; "?x * ?x + ?y * ?y = 0 ==> ?x = 0" - "real_sum_squares_cancel2"; "?x * ?x + ?y * ?y = 0 ==> ?y = 0" - "real_0_less_mult_iff"; - "real_0_le_mult_iff"; - "real_mult_less_0_iff"; "(?x * ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)" - "real_mult_le_0_iff"; -RealInt.ML:qed --------------------------------------------------------------- - "real_of_int_congruent"; - "real_of_int"; "real (Abs_Integ (intrel `` {(?i, ?j)})) = - Abs_REAL - (realrel `` - {(preal_of_prat (prat_of_pnat (pnat_of_nat ?i)), - preal_of_prat (prat_of_pnat (pnat_of_nat ?j)))})" - "inj_real_of_int"; - "real_of_int_zero"; - "real_of_one"; - "real_of_int_add"; "real ?x + real ?y = real (?x + ?y)" - "real_of_int_minus"; - "real_of_int_diff"; - "real_of_int_mult"; "real ?x * real ?y = real (?x * ?y)" - "real_of_int_Suc"; - "real_of_int_real_of_nat"; - "real_of_nat_real_of_int"; - "real_of_int_zero_cancel"; - "real_of_int_less_cancel"; - "real_of_int_inject"; - "real_of_int_less_mono"; - "real_of_int_less_iff"; - "real_of_int_le_iff"; -RealBin.ML:qed --------------------------------------------------------------- - "real_number_of"; "real (number_of ?w) = number_of ?w" - "real_numeral_0_eq_0"; - "real_numeral_1_eq_1"; - "add_real_number_of"; - "minus_real_number_of"; - "diff_real_number_of"; - "mult_real_number_of"; - "real_mult_2"; (**)"2 * ?z = ?z + ?z" - "real_mult_2_right"; (**)"?z * 2 = ?z + ?z" - "eq_real_number_of"; - "less_real_number_of"; - "le_real_number_of_eq_not_less"; - "real_minus_1_eq_m1"; "- 1 = -1"(*uminus.. = "-.."*) - "real_mult_minus1"; (**)"-1 * ?z = - ?z" - "real_mult_minus1_right"; (**)"?z * -1 = - ?z" - "zero_less_real_of_nat_iff";"(0 < real ?n) = (0 < ?n)" - "zero_le_real_of_nat_iff"; - "real_add_number_of_left"; - "real_mult_number_of_left"; - "number_of ?v * (number_of ?w * ?z) = number_of (bin_mult ?v ?w) * ?z" - "real_add_number_of_diff1"; - "real_add_number_of_diff2";"number_of ?v + (?c - number_of ?w) = - number_of (bin_add ?v (bin_minus ?w)) + ?c" - "real_of_nat_number_of"; - "real (number_of ?v) = (if neg (number_of ?v) then 0 else number_of ?v)" - "real_less_iff_diff_less_0"; "(?x < ?y) = (?x - ?y < 0)" - "real_eq_iff_diff_eq_0"; - "real_le_iff_diff_le_0"; - "left_real_add_mult_distrib"; - (**)"?i * ?u + (?j * ?u + ?k) = (?i + ?j) * ?u + ?k" - "real_eq_add_iff1"; - "(?i * ?u + ?m = ?j * ?u + ?n) = ((?i - ?j) * ?u + ?m = ?n)" - "real_eq_add_iff2"; - "real_less_add_iff1"; - "real_less_add_iff2"; - "real_le_add_iff1"; - "real_le_add_iff2"; - "real_mult_le_mono1"; - "real_mult_le_mono2"; - "real_mult_le_mono"; - "[| ?i <= ?j; ?k <= ?l; 0 <= ?j; 0 <= ?k |] ==> ?i * ?k <= ?j * ?l" -RealArith0.ML:qed ------------------------------------------------------------ - "real_diff_minus_eq"; (**)"?x - - ?y = ?x + ?y" - "real_0_divide"; (**)"0 / ?x = 0" - "real_0_less_inverse_iff"; "(0 < inverse ?x) = (0 < ?x)" - "real_inverse_less_0_iff"; - "real_0_le_inverse_iff"; - "real_inverse_le_0_iff"; - "REAL_DIVIDE_ZERO"; "?x / 0 = 0"(*!!!*) - "real_inverse_eq_divide"; - "real_0_less_divide_iff";"(0 < ?x / ?y) = (0 < ?x & 0 < ?y | ?x < 0 & ?y < 0)" - "real_divide_less_0_iff";"(?x / ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)" - "real_0_le_divide_iff"; - "real_divide_le_0_iff"; - "(?x / ?y <= 0) = ((?x <= 0 | ?y <= 0) & (0 <= ?x | 0 <= ?y))" - "real_inverse_zero_iff"; - "real_divide_eq_0_iff"; "(?x / ?y = 0) = (?x = 0 | ?y = 0)"(*!!!*) - "real_divide_self_eq"; "?h ~= 0 ==> ?h / ?h = 1"(**) - "real_minus_less_minus"; "(- ?y < - ?x) = (?x < ?y)" - "real_mult_less_mono1_neg"; "[| ?i < ?j; ?k < 0 |] ==> ?j * ?k < ?i * ?k" - "real_mult_less_mono2_neg"; - "real_mult_le_mono1_neg"; - "real_mult_le_mono2_neg"; - "real_mult_less_cancel2"; - "real_mult_le_cancel2"; - "real_mult_less_cancel1"; - "real_mult_le_cancel1"; - "real_mult_eq_cancel1"; "(?k * ?m = ?k * ?n) = (?k = 0 | ?m = ?n)" - "real_mult_eq_cancel2"; "(?m * ?k = ?n * ?k) = (?k = 0 | ?m = ?n)" - "real_mult_div_cancel1"; (**)"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n" - "real_mult_div_cancel_disj"; - "?k * ?m / (?k * ?n) = (if ?k = 0 then 0 else ?m / ?n)" - "pos_real_le_divide_eq"; - "neg_real_le_divide_eq"; - "pos_real_divide_le_eq"; - "neg_real_divide_le_eq"; - "pos_real_less_divide_eq"; - "neg_real_less_divide_eq"; - "pos_real_divide_less_eq"; - "neg_real_divide_less_eq"; - "real_eq_divide_eq"; (**)"?z ~= 0 ==> (?x = ?y / ?z) = (?x * ?z = ?y)" - "real_divide_eq_eq"; (**)"?z ~= 0 ==> (?y / ?z = ?x) = (?y = ?x * ?z)" - "real_divide_eq_cancel2"; "(?m / ?k = ?n / ?k) = (?k = 0 | ?m = ?n)" - "real_divide_eq_cancel1"; "(?k / ?m = ?k / ?n) = (?k = 0 | ?m = ?n)" - "real_inverse_less_iff"; - "real_inverse_le_iff"; - "real_divide_1"; (**)"?x / 1 = ?x" - "real_divide_minus1"; (**)"?x / -1 = - ?x" - "real_minus1_divide"; (**)"-1 / ?x = - (1 / ?x)" - "real_lbound_gt_zero"; - "[| 0 < ?d1.0; 0 < ?d2.0 |] ==> EX e. 0 < e & e < ?d1.0 & e < ?d2.0" - "real_inverse_eq_iff"; "(inverse ?x = inverse ?y) = (?x = ?y)" - "real_divide_eq_iff"; "(?z / ?x = ?z / ?y) = (?z = 0 | ?x = ?y)" - "real_less_minus"; "(?x < - ?y) = (?y < - ?x)" - "real_minus_less"; "(- ?x < ?y) = (- ?y < ?x)" - "real_le_minus"; - "real_minus_le"; "(- ?x <= ?y) = (- ?y <= ?x)" - "real_equation_minus"; (**)"(?x = - ?y) = (?y = - ?x)" - "real_minus_equation"; (**)"(- ?x = ?y) = (- ?y = ?x)" - "real_add_minus_iff"; (**)"(?x + - ?a = 0) = (?x = ?a)" - "real_minus_eq_cancel"; (**)"(- ?b = - ?a) = (?b = ?a)" - "real_add_eq_0_iff"; (**)"(?x + ?y = 0) = (?y = - ?x)" - "real_add_less_0_iff"; "(?x + ?y < 0) = (?y < - ?x)" - "real_0_less_add_iff"; - "real_add_le_0_iff"; - "real_0_le_add_iff"; - "real_0_less_diff_iff"; "(0 < ?x - ?y) = (?y < ?x)" - "real_0_le_diff_iff"; - "real_minus_diff_eq"; (**)"- (?x - ?y) = ?y - ?x" - "real_less_half_sum"; "?x < ?y ==> ?x < (?x + ?y) / 2" - "real_gt_half_sum"; - "real_dense"; "?x < ?y ==> EX r. ?x < r & r < ?y" -RealArith ///!!!///----------------------------------------------------------- -RComplete.ML:qed ------------------------------------------------------------- - "real_sum_of_halves"; (**)"?x / 2 + ?x / 2 = ?x" - "real_sup_lemma1"; - "real_sup_lemma2"; - "posreal_complete"; - "real_isLub_unique"; - "real_order_restrict"; - "posreals_complete"; - "real_sup_lemma3"; - "lemma_le_swap2"; - "lemma_real_complete2b"; - "reals_complete"; - "real_of_nat_Suc_gt_zero"; - "reals_Archimedean"; "0 < ?x ==> EX n. inverse (real (Suc n)) < ?x" - "reals_Archimedean2"; -RealAbs.ML:qed - "abs_nat_number_of"; - "abs (number_of ?v) = - (if neg (number_of ?v) then number_of (bin_minus ?v) else number_of ?v)" - "abs_split"; - "abs_iff"; - "abs_zero"; "abs 0 = 0" - "abs_one"; - "abs_eqI1"; - "abs_eqI2"; - "abs_minus_eqI2"; - "abs_minus_eqI1"; - "abs_ge_zero"; "0 <= abs ?x" - "abs_idempotent"; "abs (abs ?x) = abs ?x" - "abs_zero_iff"; "(abs ?x = 0) = (?x = 0)" - "abs_ge_self"; "?x <= abs ?x" - "abs_ge_minus_self"; - "abs_mult"; "abs (?x * ?y) = abs ?x * abs ?y" - "abs_inverse"; "abs (inverse ?x) = inverse (abs ?x)" - "abs_mult_inverse"; - "abs_triangle_ineq"; "abs (?x + ?y) <= abs ?x + abs ?y" - "abs_triangle_ineq_four"; - "abs_minus_cancel"; - "abs_minus_add_cancel"; - "abs_triangle_minus_ineq"; -RealAbs.ML:qed_spec_mp - "abs_add_less"; "[| abs ?x < ?r; abs ?y < ?s |] ==> abs (?x + ?y) < ?r + ?s" -RealAbs.ML:qed - "abs_add_minus_less"; - "real_mult_0_less"; "(0 * ?x < ?r) = (0 < ?r)" - "real_mult_less_trans"; - "real_mult_le_less_trans"; - "abs_mult_less"; - "abs_mult_less2"; - "abs_less_gt_zero"; - "abs_minus_one"; "abs -1 = 1" - "abs_disj"; "abs ?x = ?x | abs ?x = - ?x" - "abs_interval_iff"; - "abs_le_interval_iff"; - "abs_add_pos_gt_zero"; - "abs_add_one_gt_zero"; - "abs_not_less_zero"; - "abs_circle"; "abs ?h < abs ?y - abs ?x ==> abs (?x + ?h) < abs ?y" - "abs_le_zero_iff"; - "real_0_less_abs_iff"; - "abs_real_of_nat_cancel"; - "abs_add_one_not_less_self"; - "abs_triangle_ineq_three"; "abs (?w + ?x + ?y) <= abs ?w + abs ?x + abs ?y" - "abs_diff_less_imp_gt_zero"; - "abs_diff_less_imp_gt_zero2"; - "abs_diff_less_imp_gt_zero3"; - "abs_diff_less_imp_gt_zero4"; - "abs_triangle_ineq_minus_cancel"; - "abs_sum_triangle_ineq"; - "abs (?x + ?y + (- ?l + - ?m)) <= abs (?x + - ?l) + abs (?y + - ?m)" -RealPow.ML:qed - "realpow_zero"; "0 ^ Suc ?n = 0" -RealPow.ML:qed_spec_mp - "realpow_not_zero"; "?r ~= 0 ==> ?r ^ ?n ~= 0" - "realpow_zero_zero"; "?r ^ ?n = 0 ==> ?r = 0" - "realpow_inverse"; "inverse (?r ^ ?n) = inverse ?r ^ ?n" - "realpow_abs"; "abs (?r ^ ?n) = abs ?r ^ ?n" - "realpow_add"; (**)"?r ^ (?n + ?m) = ?r ^ ?n * ?r ^ ?m" - "realpow_one"; (**)"?r ^ 1 = ?r" - "realpow_two"; (**)"?r ^ Suc (Suc 0) = ?r * ?r" -RealPow.ML:qed_spec_mp - "realpow_gt_zero"; "0 < ?r ==> 0 < ?r ^ ?n" - "realpow_ge_zero"; "0 <= ?r ==> 0 <= ?r ^ ?n" - "realpow_le"; "0 <= ?x & ?x <= ?y ==> ?x ^ ?n <= ?y ^ ?n" - "realpow_less"; -RealPow.ML:qed - "realpow_eq_one"; (**)"1 ^ ?n = 1" - "abs_realpow_minus_one"; "abs (-1 ^ ?n) = 1" - "realpow_mult"; (**)"(?r * ?s) ^ ?n = ?r ^ ?n * ?s ^ ?n" - "realpow_two_le"; "0 <= ?r ^ Suc (Suc 0)" - "abs_realpow_two"; - "realpow_two_abs"; "abs ?x ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)" - "realpow_two_gt_one"; -RealPow.ML:qed_spec_mp - "realpow_ge_one"; "1 < ?r ==> 1 <= ?r ^ ?n" -RealPow.ML:qed - "realpow_ge_one2"; - "two_realpow_ge_one"; - "two_realpow_gt"; - "realpow_minus_one"; (**)"-1 ^ (2 * ?n) = 1" - "realpow_minus_one_odd"; "-1 ^ Suc (2 * ?n) = - 1" - "realpow_minus_one_even"; -RealPow.ML:qed_spec_mp - "realpow_Suc_less"; - "realpow_Suc_le"; "0 <= ?r & ?r < 1 ==> ?r ^ Suc ?n <= ?r ^ ?n" -RealPow.ML:qed - "realpow_zero_le"; "0 <= 0 ^ ?n" -RealPow.ML:qed_spec_mp - "realpow_Suc_le2"; -RealPow.ML:qed - "realpow_Suc_le3"; -RealPow.ML:qed_spec_mp - "realpow_less_le"; "0 <= ?r & ?r < 1 & ?n < ?N ==> ?r ^ ?N <= ?r ^ ?n" -RealPow.ML:qed - "realpow_le_le"; "[| 0 <= ?r; ?r < 1; ?n <= ?N |] ==> ?r ^ ?N <= ?r ^ ?n" - "realpow_Suc_le_self"; - "realpow_Suc_less_one"; -RealPow.ML:qed_spec_mp - "realpow_le_Suc"; - "realpow_less_Suc"; - "realpow_le_Suc2"; - "realpow_gt_ge"; - "realpow_gt_ge2"; -RealPow.ML:qed - "realpow_ge_ge"; "[| 1 < ?r; ?n <= ?N |] ==> ?r ^ ?n <= ?r ^ ?N" - "realpow_ge_ge2"; -RealPow.ML:qed_spec_mp - "realpow_Suc_ge_self"; - "realpow_Suc_ge_self2"; -RealPow.ML:qed - "realpow_ge_self"; - "realpow_ge_self2"; -RealPow.ML:qed_spec_mp - "realpow_minus_mult"; "0 < ?n ==> ?x ^ (?n - 1) * ?x = ?x ^ ?n" - "realpow_two_mult_inverse"; - "?r ~= 0 ==> ?r * inverse ?r ^ Suc (Suc 0) = inverse ?r" - "realpow_two_minus"; "(- ?x) ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)" - "realpow_two_diff"; - "realpow_two_disj"; - "realpow_diff"; - "[| ?x ~= 0; ?m <= ?n |] ==> ?x ^ (?n - ?m) = ?x ^ ?n * inverse (?x ^ ?m)" - "realpow_real_of_nat"; - "realpow_real_of_nat_two_pos"; "0 < real (Suc (Suc 0) ^ ?n)" -RealPow.ML:qed_spec_mp - "realpow_increasing"; - "realpow_Suc_cancel_eq"; - "[| 0 <= ?x; 0 <= ?y; ?x ^ Suc ?n = ?y ^ Suc ?n |] ==> ?x = ?y" -RealPow.ML:qed - "realpow_eq_0_iff"; "(?x ^ ?n = 0) = (?x = 0 & 0 < ?n)" - "zero_less_realpow_abs_iff"; - "zero_le_realpow_abs"; - "real_of_int_power"; "real ?x ^ ?n = real (?x ^ ?n)" - "power_real_number_of"; "number_of ?v ^ ?n = real (number_of ?v ^ ?n)" -Ring_and_Field ---///!!!///--------------------------------------------------- -Complex_Numbers --///!!!///--------------------------------------------------- -Real -------------///!!!///--------------------------------------------------- -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; -real_arith0.ML:qed ""; - - - - - - - - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/Script.thy --- a/src/Tools/isac/Scripts/Script.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,194 +0,0 @@ -(* Title: tactics, tacticals etc. for scripts - Author: Walther Neuper 000224 - (c) due to copyright terms - -use_thy_only"Scripts/Script"; -use_thy"../Scripts/Script"; -use_thy"Script"; - *) - -theory Script imports Tools begin - -typedecl - ID (* identifiers for thy, ruleset,... *) - -typedecl - arg (* argument of subproblem *) - -consts - -(*types of subproblems' arguments*) - real_' :: "real => arg" - real_list_' :: "(real list) => arg" - real_set_' :: "(real set) => arg" - bool_' :: "bool => arg" - bool_list_' :: "(bool list) => arg" - real_real_' :: "(real => real) => arg" - -(*tactics*) - Rewrite :: "[ID, bool, 'a] => 'a" - Rewrite'_Inst:: "[(real * real) list, ID, bool, 'a] => 'a" - ("(Rewrite'_Inst (_ _ _))" 11) - (*without last argument ^^ for @@*) - Rewrite'_Set :: "[ID, bool, 'a] => 'a" ("(Rewrite'_Set (_ _))" 11) - Rewrite'_Set'_Inst - :: "[(real * real) list, ID, bool, 'a] => 'a" - ("(Rewrite'_Set'_Inst (_ _ _))" 11) - (*without last argument ^^ for @@*) - Calculate :: "[ID, 'a] => 'a" (*WN100816 PLUS, TIMES, POWER miss.in scr*) - Calculate1 :: "[ID, 'a] => 'a" (*FIXXXME: unknown to script-interpreter*) - - (* WN0509 substitution now is rewriting by a list of terms (of type bool) - Substitute :: "[(real * real) list, 'a] => 'a"*) - Substitute :: "[bool list, 'a] => 'a" - - Map :: "['a => 'b, 'a list] => 'b list" - Tac :: "ID => 'a" (*deprecated; only use in Test.ML*) - Check'_elementwise :: - "['a list, 'b set] => 'a list" - ("Check'_elementwise (_ _)" 11) - Take :: "'a => 'a" (*for non-var args as long as no 'o'*) - SubProblem :: "[ID * ID list * ID list, arg list] => 'a" - - Or'_to'_List :: "bool => 'a list" ("Or'_to'_List (_)" 11) - (*=========== record these ^^^ in 'tacs' in Script.ML =========*) - - Assumptions :: bool - Problem :: "[ID * ID list] => 'a" - -(*special formulas for frontend 'CAS format'*) - Subproblem :: "(ID * ID list) => 'a" - -(*script-expressions (tacticals)*) - Seq :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "@@" 10) (*@ used*) - Try :: "['a => 'a, 'a] => 'a" - Repeat :: "['a => 'a, 'a] => 'a" - Or :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "Or" 10) - While :: "[bool, 'a => 'a, 'a] => 'a" ("((While (_) Do)//(_))" 9) -(*WN100723 because of "Error in syntax translation" below... - (*'b => bool doesn't work with "contains_root _"*) - Letpar :: "['a, 'a => 'b] => 'b" - (*--- defined in Isabelle/scr/HOL/HOL.thy: - Let :: "['a, 'a => 'b] => 'b" - "_Let" :: "[letbinds, 'a] => 'a" ("(let (_)/ in (_))" 10) - If :: "[bool, 'a, 'a] => 'a" ("(if (_)/ then (_)/ else (_))" 10) - %x. P x .. lambda is defined in Isabelles meta logic - --- *) -*) - failtac :: 'a - idletac :: 'a - (*... + RECORD IN 'screxpr' in Script.ML *) - -(*for scripts generated automatically from rls*) - Stepwise :: "['z, 'z] => 'z" ("((Script Stepwise (_ =))// (_))" 9) - Stepwise'_inst:: "['z,real,'z] => 'z" - ("((Script Stepwise'_inst (_ _ =))// (_))" 9) - - -(*SHIFT -> resp.thys ----vvv---------------------------------------------*) -(*script-names: initial capital letter, - type of last arg (=script-body) == result-type ! - Xxxx :: script ids, duplicate result-type 'r in last argument: - "['a, ... , \ - \ 'r] => 'r -*) - -(*make'_solution'_set :: "bool => bool list" - ("(make'_solution'_set (_))" 11) - - max'_on'_interval - :: "[ID * (ID list) * ID, bool,real,real set] => real" - ("(max'_on'_interval (_)/ (_ _ _))" 9) - find'_vals - :: "[ID * (ID list) * ID, - real,real,real,real,bool list] => bool list" - ("(find'_vals (_)/ (_ _ _ _ _))" 9) - - make'_fun :: "[ID * (ID list) * ID, real,real,bool list] => bool" - ("(make'_fun (_)/ (_ _ _))" 9) - - solve'_univar - :: "[ID * (ID list) * ID, bool,real] => bool list" - ("(solve'_univar (_)/ (_ _ ))" 9) - solve'_univar'_err - :: "[ID * (ID list) * ID, bool,real,bool] => bool list" - ("(solve'_univar (_)/ (_ _ _))" 9) -----------*) - - Testeq :: "[bool, bool] => bool" - ("((Script Testeq (_ =))// - (_))" 9) - - Testeq2 :: "[bool, bool list] => bool list" - ("((Script Testeq2 (_ =))// - (_))" 9) - - Testterm :: "[real, real] => real" - ("((Script Testterm (_ =))// - (_))" 9) - - Testchk :: "[bool, real, real list] => real list" - ("((Script Testchk (_ _ =))// - (_))" 9) - (*... + RECORD IN 'subpbls' in Script.ML *) -(*SHIFT -> resp.thys ----^^^----------------------------*) - -(*Makarius 10.03 -syntax - - "_Letpar" :: "[letbinds, 'a] => 'a" ("(letpar (_)/ in (_))" 10) - -translations - - "_Letpar (_binds b bs) e" == "_Letpar b (_Letpar bs e)" - "letpar x = a in e" == "Letpar a (%x. e)" -*** Error in syntax translation rule: rhs contains extra variables -*** ("_Letpar" ("_bind" x a) e) -> (Letpar a ("_abs" x e)) -*** At command "translations" (line 140 of "/usr/local/isabisac/src/Pure/isac/Scripts/Script.thy"). -*) - -ML {* (*the former Script.ML*) - -(*.record all theories defined for Scripts; in order to distinguish them - from general IsacKnowledge defined later on.*) -script_thys := !theory'; - -(*--vvv----- SHIFT? or delete ?*) -val IDTyp = Type("Script.ID",[]); - - -val tacs = ref (distinct (remove op = "" - ["Calculate", - "Rewrite","Rewrite'_Inst","Rewrite'_Set","Rewrite'_Set'_Inst", - "Substitute","Tac","Check'_elementswise", - "Take","Subproblem","Or'_to'_List"])); - -val screxpr = ref (distinct (remove op = "" - ["Let","If","Repeat","While","Try","Or"])); - -val listfuns = ref [(*_all_ functions in Isa99.List.thy *) - "@","filter","concat","foldl","hd","last","set","list_all", - "map","mem","nth","list_update","take","drop", - "takeWhile","dropWhile","tl","butlast", - "rev","zip","upt","remdups","nodups","replicate", - - "Cons","Nil"]; - -val scrfuns = ref (distinct (remove op = "" - ["Testvar"])); - -val listexpr = ref (union op = (!listfuns) (!scrfuns)); - -val notsimp = ref - (distinct (remove op = "" - (!tacs @ !screxpr @ (*!subpbls @*) !scrfuns @ !listfuns))); - -val negotiable = ref ((!tacs (*@ !subpbls*))); - -val tacpbl = ref - (distinct (remove op = "" (!tacs (*@ !subpbls*)))); -(*--^^^----- SHIFT? or delete ?*) - -*} - -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/Tools.sml --- a/src/Tools/isac/Scripts/Tools.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -(* = Tools.ML - +++ outcommented tests *) - - -fun eval_var (thmid:string) (op_:string) - (t as (Const(op0,t0) $ arg)) thy = - let - val t' = ((list2isalist HOLogic.realT) o vars) t; - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg); - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end - | eval_var _ _ _ _ = raise GO_ON; -(* -> val t = (term_of o the o (parse thy)) "Var (A=a*(b::real))"; -> val op_ = "Var"; -> val eval_fn = the (assoc (!eval_list, op_)); -> get_pair op_ eval_fn t; -> val (t as (Const(op0,t0) $ arg)) = t; -> eval_fn op0 t; - -> val thmid = "#Var_"; -> val (SOME(thmId,t')) = eval_var thmid op0 t; -val it = SOME ("#Var_(A::real) = (a::real) * (b::real)",Const # $ (# $ #)) - : (string * term) option -> Syntax.string_of_term (thy2ctxt thy) t'; -val it = "Var ((A::real) = (a::real) * (b::real)) = [A, a, b]" : string -*) -fun eval_Length (thmid:string) (op_:string) - (t as (Const(op0,t0) $ arg)) thy = - let - val t' = ((term_of_num HOLogic.realT) o length o isalist2list) arg; - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg); - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end - | eval_Length _ _ _ _ = raise GO_ON; -(* -> val thmid = "#Length_"; val op_ = "Length"; -> val s = "Length [A = a * b, a // #2 = #2]"; -> val (t as (Const(op0,t0) $ arg)) = (term_of o the o (parse thy)) s; -> val (SOME (id,t')) = eval_Length thmid op_ t; -val id = "#Length_[A = a * b, a // #2 = #2]" : string -val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#)) -val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm ---------------------------------------------- -> val thmid = "#Length_"; val op_ = "Length"; -> val s = - "if #1 < Length [A = a * b, a // #2 = #2] \ - \then make_fun (R, [make, function], no_met) A a_ [A = a * b, a // #2 = #2]\ - \else hd [A = a * b, a // #2 = #2]"; - -> (cterm_of thy) t'; -> val t = (term_of o the o (parse thy)) s; -> val eval_fn = the (assoc (!eval_list, op_)); -> val (SOME(_,t')) = get_pair op_ eval_fn t; -val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#)) -val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm - -> val ct = (the o (parse thy)) s; -> val (SOME(_,thm)) = get_calculation thy (op_, eval_fn) ct; -val thm = "Length [A = a * b, a // #2 = #2] = #2" [[ Free ( #2, real) !!!]] -> rewrite_ thy tless_true e_rls false thm ct; -("if #1 < #2 - then make_fun (R, [make, function], no_met) - A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]", - []) : (cterm * cterm list) option -> val ct = (the o (parse thy)) s; -> rewrite_set_ thy e_rls false eval_script ct; -("if #1 < #2 - then make_fun (R, [make, function], no_met) - A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]", - []) : (cterm * cterm list) option -*) - -fun eval_Nth (thmid:string) (op_:string) (t as - (Const (op0,t0) $ t1 $ t2 )) thy = -(writeln"@@@ eval_Nth"; - if is_num t1 andalso is_list t2 - then - let - val t' = (nth (num_of_term t1) (isalist2list t2)) - handle _ => raise GO_ON; - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) t1)^ - "_"^(Syntax.string_of_term (thy2ctxt thy) t2)^ - " = "^(Syntax.string_of_term (thy2ctxt thy) t'); - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end - else raise GO_ON -) - | eval_Nth _ _ _ _ = raise GO_ON; -(* -> val thmid = "#Nth_"; val op_ = "Nth"; -> val s = "Nth #2 [A = a * b, a // #2 = #2]"; -> val t = (term_of o the o (parse thy)) s; -> eval_Nth thmid op_ t; - -> val eval_fn = the (assoc (!eval_list, op_)); -> val (SOME(id,t')) = get_pair op_ eval_fn t; -> (cterm_of thy) t'; -val it = "Nth #2 [A = a * b, a // #2 = #2] = (a // #2 = #2)" -*) - - -(*17.6.00: calc_list instead eval_list*) -eval_list:= overwritel (! eval_list, - [("Var",eval_var "#Var_"), - ("Length",eval_Length "#Length_"), - ("Nth",eval_Nth "#Nth_") - ]); -(*17.6.00: association list for calculate_, calculate*) -calc_list:= overwritel (! calc_list, - [ - ("Var" ,("Var",eval_var "#Var_")), - ("Length",("Length",eval_Length "#Length_")), - ("Nth" ,("Nth",eval_Nth "#Nth_")) - ]); - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/Tools.thy --- a/src/Tools/isac/Scripts/Tools.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,230 +0,0 @@ -(* auxiliary functions used in scripts - author: Walther Neuper 000301 - WN0509 shift into Atools ?!? (because used also in where of models !) - - (c) copyright due to lincense terms. - -remove_thy"Tools"; -use_thy"Scripts/Tools"; -*) - -theory Tools imports ListG begin - -(*belongs to theory ListG*) -ML {* -val first_isac_thy = @{theory ListG} -*} - -(*for Descript.thy*) - - (***********************************************************************) - (* 'fun is_dsc' in Scripts/scrtools.smlMUST contain ALL these types !!!*) - (***********************************************************************) -typedecl nam (* named variables *) -typedecl una (* unnamed variables *) -typedecl unl (* unnamed variables of type list, elementwise input prohibited*) -typedecl str (* structured variables *) -typedecl toreal (* var with undef real value: forces typing *) -typedecl toreall (* var with undef real list value: forces typing *) -typedecl tobooll (* var with undef bool list value: forces typing *) -typedecl unknow (* input without dsc in fmz=[] *) -typedecl cpy (* UNUSED: copy-named variables - identified by .._0, .._i .._' in pbt *) - (***********************************************************************) - (* 'fun is_dsc' in Scripts/scrtools.smlMUST contain ALL these types !!!*) - (***********************************************************************) - -consts - - UniversalList :: "bool list" - - lhs :: "bool => real" (*of an equality*) - rhs :: "bool => real" (*of an equality*) - Vars :: "'a => real list" (*get the variables of a term *) - matches :: "['a, 'a] => bool" - matchsub :: "['a, 'a] => bool" - -constdefs - - Testvar :: "[real, 'a] => bool" (*is a variable in a term: unused 6.5.03*) - "Testvar v t == v mem (Vars t)" (*by rewriting only,no Calcunused 6.5.03*) - -ML {* (*the former Tools.ML*) -(* auxiliary functions for scripts WN.9.00*) -(*11.02: for equation solving only*) -val UniversalList = (term_of o the o (parse @{theory})) "UniversalList"; -val EmptyList = (term_of o the o (parse @{theory})) "[]::bool list"; - -(*+ for Or_to_List +*) -fun or2list (Const ("True",_)) = (writeln"### or2list True";UniversalList) - | or2list (Const ("False",_)) = (writeln"### or2list False";EmptyList) - | or2list (t as Const ("op =",_) $ _ $ _) = - (writeln"### or2list _ = _";list2isalist bool [t]) - | or2list ors = - (writeln"### or2list _ | _"; - let fun get ls (Const ("op |",_) $ o1 $ o2) = - case o2 of - Const ("op |",_) $ _ $ _ => get (ls @ [o1]) o2 - | _ => ls @ [o1, o2] - in (((list2isalist bool) o (get [])) ors) - handle _ => raise error ("or2list: no ORs= "^(term2str ors)) end - ); -(*>val t = HOLogic.true_const; -> val t' = or2list t; -> term2str t'; -"Atools.UniversalList" -> val t = HOLogic.false_const; -> val t' = or2list t; -> term2str t'; -"[]" -> val t=(term_of o the o (parse thy)) "x=3"; -> val t' = or2list t; -> term2str t'; -"[x = 3]" -> val t=(term_of o the o (parse thy))"(x=3) | (x=-3) | (x=0)"; -> val t' = or2list t; -> term2str t'; -"[x = #3, x = #-3, x = #0]" : string *) - - -(** evaluation on the meta-level **) - -(*. evaluate the predicate matches (match on whole term only) .*) -(*("matches",("Tools.matches",eval_matches "#matches_")):calc*) -fun eval_matches (thmid:string) "Tools.matches" - (t as Const ("Tools.matches",_) $ pat $ tst) thy = - if matches thy tst pat - then let val prop = Trueprop $ (mk_equality (t, true_as_term)) - in SOME (Syntax.string_of_term @{context} prop, prop) end - else let val prop = Trueprop $ (mk_equality (t, false_as_term)) - in SOME (Syntax.string_of_term @{context} prop, prop) end - | eval_matches _ _ _ _ = NONE; -(* -> val t = (term_of o the o (parse thy)) - "matches (?x = 0) (1 * x ^^^ 2 = 0)"; -> eval_matches "/thmid/" "/op_/" t thy; -val it = - SOME - ("matches (x = 0) (1 * x ^^^ 2 = 0) = False", - Const (#,#) $ (# $ # $ Const #)) : (string * term) option - -> val t = (term_of o the o (parse thy)) - "matches (?a = #0) (#1 * x ^^^ #2 = #0)"; -> eval_matches "/thmid/" "/op_/" t thy; -val it = - SOME - ("matches (?a = #0) (#1 * x ^^^ #2 = #0) = True", - Const (#,#) $ (# $ # $ Const #)) : (string * term) option - -> val t = (term_of o the o (parse thy)) - "matches (?a * x = #0) (#1 * x ^^^ #2 = #0)"; -> eval_matches "/thmid/" "/op_/" t thy; -val it = - SOME - ("matches (?a * x = #0) (#1 * x ^^^ #2 = #0) = False", - Const (#,#) $ (# $ # $ Const #)) : (string * term) option - -> val t = (term_of o the o (parse thy)) - "matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0)"; -> eval_matches "/thmid/" "/op_/" t thy; -val it = - SOME - ("matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0) = True", - Const (#,#) $ (# $ # $ Const #)) : (string * term) option ------ before ?patterns ---: -> val t = (term_of o the o (parse thy)) - "matches (a * b^^^#2 = c) (#3 * x^^^#2 = #1)"; -> eval_matches "/thmid/" "/op_/" t thy; -SOME - ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2 = #1) = True", - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) - : (string * term) option - -> val t = (term_of o the o (parse thy)) - "matches (a * b^^^#2 = c) (#3 * x^^^#2222 = #1)"; -> eval_matches "/thmid/" "/op_/" t thy; -SOME ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2222 = #1) = False", - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) - -> val t = (term_of o the o (parse thy)) - "matches (a = b) (x + #1 + #-1 * #2 = #0)"; -> eval_matches "/thmid/" "/op_/" t thy; -SOME ("matches (a = b) (x + #1 + #-1 * #2 = #0) = True",Const # $ (# $ #)) -*) - -(*.does a pattern match some subterm ?.*) -fun matchsub thy t pat = - let fun matchs (t as Const _) = matches thy t pat - | matchs (t as Free _) = matches thy t pat - | matchs (t as Var _) = matches thy t pat - | matchs (Bound _) = false - | matchs (t as Abs (_, _, body)) = - if matches thy t pat then true else matches thy body pat - | matchs (t as f1 $ f2) = - if matches thy t pat then true - else if matchs f1 then true else matchs f2 - in matchs t end; - -(*("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")):calc*) -fun eval_matchsub (thmid:string) "Tools.matchsub" - (t as Const ("Tools.matchsub",_) $ pat $ tst) thy = - if matchsub thy tst pat - then let val prop = Trueprop $ (mk_equality (t, true_as_term)) - in SOME (Syntax.string_of_term @{context} prop, prop) end - else let val prop = Trueprop $ (mk_equality (t, false_as_term)) - in SOME (Syntax.string_of_term @{context} prop, prop) end - | eval_matchsub _ _ _ _ = NONE; - -(*get the variables in an isabelle-term*) -(*("Vars" ,("Tools.Vars" ,eval_var "#Vars_")):calc*) -fun eval_var (thmid:string) "Tools.Vars" - (t as (Const(op0,t0) $ arg)) thy = - let - val t' = ((list2isalist HOLogic.realT) o vars) t; - val thmId = thmid^(Syntax.string_of_term @{context} arg); - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end - | eval_var _ _ _ _ = NONE; - -fun lhs (Const ("op =",_) $ l $ _) = l - | lhs t = error("lhs called with (" ^ term2str t ^ ")"); -(*("lhs" ,("Tools.lhs" ,eval_lhs "")):calc*) -fun eval_lhs _ "Tools.lhs" - (t as (Const ("Tools.lhs",_) $ (Const ("op =",_) $ l $ _))) _ = - SOME ((term2str t) ^ " = " ^ (term2str l), - Trueprop $ (mk_equality (t, l))) - | eval_lhs _ _ _ _ = NONE; -(* -> val t = (term_of o the o (parse thy)) "lhs (1 * x ^^^ 2 = 0)"; -> val SOME (id,t') = eval_lhs 0 0 t 0; -val id = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string -> term2str t'; -val it = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string -*) - -fun rhs (Const ("op =",_) $ _ $ r) = r - | rhs t = error("rhs called with (" ^ term2str t ^ ")"); -(*("rhs" ,("Tools.rhs" ,eval_rhs "")):calc*) -fun eval_rhs _ "Tools.rhs" - (t as (Const ("Tools.rhs",_) $ (Const ("op =",_) $ _ $ r))) _ = - SOME ((term2str t) ^ " = " ^ (term2str r), - Trueprop $ (mk_equality (t, r))) - | eval_rhs _ _ _ _ = NONE; - - -(*for evaluating scripts*) - -val list_rls = append_rls "list_rls" list_rls - [Calc ("Tools.rhs",eval_rhs "")]; -ruleset' := overwritelthy @{theory} (!ruleset', - [("list_rls",list_rls) - ]); -calclist':= overwritel (!calclist', - [("matches",("Tools.matches",eval_matches "#matches_")), - ("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")), - ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")), - ("lhs" ,("Tools.lhs" ,eval_lhs "")), - ("rhs" ,("Tools.rhs" ,eval_rhs "")) - ]); - -*} -end diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/calculate.sml --- a/src/Tools/isac/Scripts/calculate.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,408 +0,0 @@ -(* calculate values for function constants - (c) Walther Neuper 000106 - -use"Scripts/calculate.sml"; -*) - - -(* dirty type-conversion 30.1.00 for "fixed_values [R=R]" *) - -val aT = Type ("'a", []); -(* isas types for Free, parseold: (1) "R=R" or (2) "R=(R::real)": -(1) -> val (TFree(ss2,TT2)) = T2; -val ss2 = "'a" : string -val TT2 = ["term"] : sort -(2) -> val (Type(ss2',TT2')) = T2'; -val ss2' = "RealDef.real" : string -val TT2' = [] : typ list -(3) -val realType = TFree ("RealDef.real", HOLogic.termS); -is different internally, too; - -(1) .. (3) are displayed equally !!! -*) - - - -(* 30.1.00: generating special terms for ME: - (1) binary numerals reconverted to Free ("#num",...) - by libarary_G.num_str: called from parse (below) and - interface_ME_ISA for all thms used - (compare HOLogic.dest_binum) - (2) 'a types converted to RealDef.real by typ_a2real - in parse below - (3) binary operators fixed to type real in RatArith.thy - (trick by Markus Wenzel) -*) - - - - -(** calculate numerals **) - -(*27.3.00: problems with patterns below: -"Vars (a // #2 = r * xxxxx b)" doesn't work, but -"Vars (a // #2 = r * sqrt b)" works -*) - -fun popt2str (SOME (str, term)) = "SOME "^term2str term - | popt2str NONE = "NONE"; - -(* scan a term for applying eval_fn ef -args - thy: - op_: operator (as string) selecting the root of the pair - ef : fn : (string -> term -> theory -> (string * term) option) - ^^^^^^... for creating the string for the resulting theorem - t : term to be scanned -result: - (string * term) option: found by the eval_* -function of type - fn : string -> string -> term -> theory -> (string * term) option - ^^^^^^... the selecting operator op_ (variable for eval_binop) -*) -fun get_pair thy op_ (ef:string -> term -> theory -> (string * term) option) - (t as (Const(op0,t0) $ arg)) = (* unary fns *) -(* val (thy, op_, (ef), (t as (Const(op0,t0) $ arg))) = - (thy, op_, eval_fn, ct); - *) - if op_ = op0 then - let val popt = ef op_ t thy - in case popt of - SOME _ => popt - | NONE => get_pair thy op_ ef arg end - else get_pair thy op_ ef arg - - | get_pair thy "Atools.ident" ef (t as (Const("Atools.ident",t0) $ _ $ _ )) = -(* val (thy, "Atools.ident", ef, t as (Const(op0,_) $ t1 $ t2)) = - (thy, op_, eval_fn, ct); - *) - ef "Atools.ident" t thy (* not nested *) - - | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2)) = (* binary funs*) -(* val (thy, op_, ef, (t as (Const(op0,_) $ t1 $ t2))) = - (thy, op_, eval_fn, ct); - *) - ((*writeln("1.. get_pair: binop = "^op_);*) - if op_ = op0 then - let val popt = ef op_ t thy - (*val _ = writeln("2.. get_pair: "^term2str t^" -> "^popt2str popt)*) - in case popt of - SOME (id,_) => popt - | NONE => - let val popt = get_pair thy op_ ef t1 - (*val _ = writeln("3.. get_pair: "^term2str t1^ - " -> "^popt2str popt)*) - in case popt of - SOME (id,_) => popt - | NONE => get_pair thy op_ ef t2 - end - end - else (*search subterms*) - let val popt = get_pair thy op_ ef t1 - (*val _ = writeln("4.. get_pair: "^term2str t^" -> "^popt2str popt)*) - in case popt of - SOME (id,_) => popt - | NONE => get_pair thy op_ ef t2 - end) - | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2 $ t3)) =(* trinary funs*) - ((*writeln("### get_pair 4a: t= "^term2str t); - writeln("### get_pair 4a: op_= "^op_); - writeln("### get_pair 4a: op0= "^op0);*) - if op_ = op0 then - case ef op_ t thy of - SOME tt => SOME tt - | NONE => (case get_pair thy op_ ef t2 of - SOME tt => SOME tt - | NONE => get_pair thy op_ ef t3) - else (case get_pair thy op_ ef t1 of - SOME tt => SOME tt - | NONE => (case get_pair thy op_ ef t2 of - SOME tt => SOME tt - | NONE => get_pair thy op_ ef t3))) - | get_pair thy op_ ef (Const _) = NONE - | get_pair thy op_ ef (Free _) = NONE - | get_pair thy op_ ef (Var _) = NONE - | get_pair thy op_ ef (Bound _) = NONE - | get_pair thy op_ ef (Abs(a,T,body)) = get_pair thy op_ ef body - | get_pair thy op_ ef (t1$t2) = - let(*val _= writeln("5.. get_pair t1 $ t2: "^term2str t1^" - $ "^term2str t2)*) - val popt = get_pair thy op_ ef t1 - in case popt of - SOME _ => popt - | NONE => ((*writeln"### get_pair: t1 $ t2 -> NONE";*) - get_pair thy op_ ef t2) - end; - (* -> val t = (term_of o the o (parse thy)) "#3 + #4"; -> val eval_fn = the (assoc (!eval_list, "op +")); -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> atomty t'; -> -> val t = (term_of o the o (parse thy)) "(a + #3) + #4"; -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "#3 + (#4 + (a::real))"; -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "x = #5 * (#3 + (#4 + a))"; -> atomty t; -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> val it = "#3 + (#4 + a) = #7 + a" : string -> -> -> val t = (term_of o the o (parse thy)) "#-4//#-2"; -> val eval_fn = the (assoc (!eval_list, "cancel")); -> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "#2^^^#3"; -> eval_binop "xxx" "pow" t thy; -> val eval_fn = (eval_binop "xxx") -> : string -> term -> theory -> (string * term) option; -> val SOME (id,t') = get_pair thy "pow" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> val eval_fn = the (assoc (!eval_list, "pow")); -> val (SOME (id,t')) = get_pair thy "pow" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4"; -> val eval_fn = the (assoc (!eval_list, "op *")); -> val (SOME (id,t')) = get_pair thy "op *" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "#0 < #4"; -> val eval_fn = the (assoc (!eval_list, "op <")); -> val (SOME (id,t')) = get_pair thy "op <" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> val t = (term_of o the o (parse thy)) "#0 < #-4"; -> val (SOME (id,t')) = get_pair thy "op <" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "#3 is_const"; -> val eval_fn = the (assoc (!eval_list, "is'_const")); -> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> val t = (term_of o the o (parse thy)) "a is_const"; -> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "#6//(#8::real)"; -> val eval_fn = the (assoc (!eval_list, "cancel")); -> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "sqrt #12"; -> val eval_fn = the (assoc (!eval_list, "SqRoot.sqrt")); -> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> val it = "sqrt #12 = #2 * sqrt #3 " : string -> -> val t = (term_of o the o (parse thy)) "sqrt #9"; -> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -> -> val t = (term_of o the o (parse thy)) "Nth #2 [#11,#22,#33]"; -> val eval_fn = the (assoc (!eval_list, "Tools.Nth")); -> val (SOME (id,t')) = get_pair thy "Tools.Nth" eval_fn t; -> Syntax.string_of_term (thy2ctxt thy) t'; -*) - -(* val ((op_, eval_fn),ct)=(cc,pre); - (get_calculation_ Isac.thy (op_, eval_fn) ct) handle e => print_exn e; - parse thy "" - *) -(*.get a thm from an op_ somewhere in the term; - apply ONLY to (uminus_to_string term), uminus_to_string (- 4711) --> (-4711).*) -fun get_calculation_ thy (op_, eval_fn) ct = -(* val (thy, (op_, eval_fn), ct) = - (thy, (the (assoc(!calclist',"order_system"))), t); - *) - case get_pair thy op_ eval_fn ct of - NONE => ((*writeln("@@@ get_calculation: NONE, op_="^op_); - writeln("@@@ get_calculation: ct= ");atomty ct;*) - NONE) - | SOME (thmid,t) => - ((*writeln("@@@ get_calculation: NONE, op_="^op_); - writeln("@@@ get_calculation: ct= ");atomty ct;*) - SOME (thmid, (make_thm o (cterm_of thy)) t)); -(* -> val ct = (the o (parse thy)) "#9 is_const"; -> get_calculation_ thy ("is'_const",the (assoc(!eval_list,"is'_const"))) ct; -val it = SOME ("is_const9_","(is_const 9 ) = True [(is_const 9 ) = True]") - -> val ct = (the o (parse thy)) "sqrt #9"; -> get_calculation_ thy ("sqrt",the (assoc(!eval_list,"sqrt"))) ct; -val it = SOME ("sqrt_9_","sqrt 9 = 3 [sqrt 9 = 3]") : (string * thm) option - -> val ct = (the o (parse thy)) "#4<#4"; -> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;fun is_no str = (hd o explode) str = "#"; - -val it = SOME ("less_5_4","(5 < 4) = False [(5 < 4) = False]") - -> val ct = (the o (parse thy)) "a<#4"; -> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct; -val it = NONE : (string * thm) option - -> val ct = (the o (parse thy)) "#5<=#4"; -> get_calculation_ thy ("op <=",the (assoc(!eval_list,"op <="))) ct; -val it = SOME ("less_equal_5_4","(5 <= 4) = False [(5 <= 4) = False]") - --------------------------------------------------------------------6.8.02: - val thy = SqRoot.thy; - val t = (term_of o the o (parse thy)) "1+2"; - get_calculation_ thy (the(assoc(!calc_list,"PLUS"))) t; - val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option --------------------------------------------------------------------6.8.02: - val t = (term_of o the o (parse thy)) "-1"; - atomty t; - val t = (term_of o the o (parse thy)) "0"; - atomty t; - val t = (term_of o the o (parse thy)) "1"; - atomty t; - val t = (term_of o the o (parse thy)) "2"; - atomty t; - val t = (term_of o the o (parse thy)) "999999999"; - atomty t; --------------------------------------------------------------------6.8.02: - -> val ct = (the o (parse thy)) "a+#3+#4"; -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; -val it = SOME ("add_3_4","a + 3 + 4 = a + 7 [a + 3 + 4 = a + 7]") - -> val ct = (the o (parse thy)) "#3+(#4+a)"; -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; -val it = SOME ("add_3_4","3 + (4 + a) = 7 + a [3 + (4 + a) = 7 + a]") - -> val ct = (the o (parse thy)) "a+(#3+#4)+#5"; -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct; -val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option - -> val ct = (the o (parse thy)) "#3*(#4*a)"; -> get_calculation_ thy ("op *",the (assoc(!eval_list,"op *"))) ct; -val it = SOME ("mult_3_4","3 * (4 * a) = 12 * a [3 * (4 * a) = 12 * a]") - -> val ct = (the o (parse thy)) "#3 + #4^^^#2 + #5"; -> get_calculation_ thy ("pow",the (assoc(!eval_list,"pow"))) ct; -val it = SOME ("4_(+2)","4 ^ 2 = 16 [4 ^ 2 = 16]") : (string * thm) option - -> val ct = (the o (parse thy)) "#-4//#-2"; -> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct; -val it = SOME ("cancel_(-4)_(-2)","(-4) // (-2) = (+2) [(-4) // (-2) = (+2)]") - -> val ct = (the o (parse thy)) "#6//#-8"; -> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct; -val it = SOME ("cancel_6_(-8)","6 // (-8) = (-3) // 4 [6 // (-8) = (-3) // 4]") - -*) - - -(* -> val ct = (the o (parse thy)) "a + 3*4"; -> applicable "calculate" (Calc("op *", "mult_")) ct; -val it = SOME "3 * 4 = 12 [3 * 4 = 12]" : thm option - --------------------------- -> val ct = (the o (parse thy)) "3 =!= 3"; -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); -val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm - -> val ct = (the o (parse thy)) "~ (3 =!= 3)"; -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); -val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm - -> val ct = (the o (parse thy)) "3 =!= 4"; -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); -val thm = "(3 =!= 4) = False [(3 =!= 4) = False]" : thm - -> val ct = (the o (parse thy)) "( 4 + (4 * x + x ^ 2) =!= (+0))"; -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); - "(4 + (4 * x + x ^ 2) =!= (+0)) = False" - -> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))"; -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct); - "(4 + (4 * x + x ^ 2) =!= (+0)) = False" - -> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))"; -> val rls = eval_rls; -> val (ct,_) = the (rewrite_set_ thy false rls ct); -val ct = "True" : cterm --------------------------- -*) - - -(*.get a thm applying an op_ to a term; - apply ONLY to (numbers_to_string term), numbers_to_string (- 4711) --> (-4711).*) -(* val (thy, (op_, eval_fn), ct) = - (thy, ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_"), term); - *) -fun get_calculation1_ thy ((op_, eval_fn):cal) ct = - case eval_fn op_ ct thy of - NONE => NONE - | SOME (thmid,t) => - SOME (thmid, (make_thm o (cterm_of thy)) t); - - - - - -(*.substitute bdv in an rls and leave Calc as they are.(*28.10.02*) -fun inst_thm' subs (Thm (id, thm)) = - Thm (id, (*read_instantiate throws: *** No such variable in term: ?bdv*) - (read_instantiate subs thm) handle _ => thm) - | inst_thm' _ calc = calc; -fun inst_thm' (subs as (bdv,_)::_) (Thm (id, thm)) = - Thm (id, (writeln("@@@ inst_thm': thm= "^(string_of_thmI thm)); - if bdv mem (vars_str o #prop o rep_thm) thm - then (writeln("@@@ inst_thm': read_instantiate, thm="^((string_of_thmI thm))); - read_instantiate subs thm) - else (writeln("@@@ inst_thm': not mem.. "^bdv); - thm))) - | inst_thm' _ calc = calc; - -fun instantiate_rls subs - (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca, - asm_thm=at,rules=rules,scr=scr}:rls) = - (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca, - asm_thm=at,scr=scr, - rules = map (inst_thm' subs) rules}:rls);---------------------------*) - - - -(** rewriting: ordered, conditional **) - -fun mk_rule (prems,l,r) = - Trueprop $ (list_implies (prems, mk_equality (l,r))); - -(* 'norms' a rule, e.g. -(*1*) a = 1 ==> a*(b+c) = b+c - => a = 1 ==> a*(b+c) = b+c no change -(*2*) t = t => (t=t) = True !! -(*3*) [| k < l; m + l = k + n |] ==> m < n - => [| k m < n = True !! *) -(* val it = fn : term -> term *) -fun norm rule = - let - val (prems,concl)=(map strip_trueprop(Logic.strip_imp_prems rule), - (strip_trueprop o Logic.strip_imp_concl)rule) - in if is_equality concl then - let val (l,r) = dest_equals' concl - in if l = r then - (*2*) mk_rule(prems,concl,true_as_term) - else (*1*) rule end - else (*3*) mk_rule(prems,concl,true_as_term) - end; - - - - - - - - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/rewrite.sml --- a/src/Tools/isac/Scripts/rewrite.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,736 +0,0 @@ -(* isac's rewriter - (c) Walther Neuper 2000 - -use"Scripts/rewrite.sml"; -use"rewrite.sml"; -*) - - -exception NO_REWRITE; -exception STOP_REW_SUB; (*WN050820 quick and dirty*) - -(*17.6.00: rewrite by going down the term with rew_sub*) -(* val (thy, i, bdv, tless, rls, put_asm, thm, ct) = - (thy, 1, []:(Term.term * Term.term) list, rew_ord, erls, bool,thm,term); - *) -fun rewrite__ thy i bdv tless rls put_asm thm ct = - ((*writeln ("@@@ r..te__ begin: t = "^(term2str ct));*) - let - val (t',asms,lrd,rew) = - rew_sub thy i bdv tless rls put_asm [(*root of the term*)] - (((inst_bdv bdv) o norm o #prop o rep_thm) thm) ct; - in if rew then SOME (t', distinct asms) - else NONE end) -(* val(r,t)=(((inst_bdv bdv) o norm o #prop o rep_thm) thm,ct); - val t1 = (#prop o rep_thm) thm; - val t2 = norm t1; - val t3 = inst_bdv bdv t2; - - val thm4 = read_instantiate [("bdv","x")] thm; - val t4 = (norm o #prop o rep_thm) thm4; - *) -(* val (thy, i, bdv, tless, rls, put_asm, r, t) = - (thy, i,bdv, tless, rls, put_asm, - (((inst_bdv bdv) o norm o #prop o rep_thm) thm), ct); - val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) = - (thy, 1, [], ord, erls,false, [], r, t); - val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) = - (thy, i, bdv, tless, rls, put_asm, [], - ((inst_bdv bdv) o norm o #prop o rep_thm) thm, ct); - *) -and rew_sub thy i bdv tless rls put_asm lrd r t = - ((*writeln ("@@@ rew_sub begin: t = "^(term2str t));*) - let (* copy from Pure/thm.ML: fun rewritec *) - (*val (lhs,rhs) = (dest_equals' o strip_trueprop - o Logic.strip_imp_concl) r; - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs,t); - val r' = ren_inst (insts, r, lhs, t); - val p' = map strip_trueprop (Logic.strip_imp_prems r'); - val t' = (snd o dest_equals' o strip_trueprop - o Logic.strip_imp_concl) r';*) - val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop - o Logic.strip_imp_concl) r; - val r' = Envir.subst_term (Pattern.match thy (lhs, t) - (Vartab.empty, Vartab.empty)) r; - val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r'); - val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop - o Logic.strip_imp_concl) r'; - (*val _= writeln("@@@ rew_sub match: t'= "^(term2str t'));*) - val _= if ! trace_rewrite andalso i < ! depth andalso p' <> [] - then writeln((idt"#"(i+1))^" eval asms: "^(term2str r')) else(); - val (t'',p'') = (*conditional rewriting*) - let val (simpl_p', nofalse) = eval__true thy (i+1) p' bdv rls - in if nofalse - then (if ! trace_rewrite andalso i < ! depth andalso p' <> [] - then writeln((idt"#"(i+1))^" asms accepted: "^(terms2str p')^ - " stored: "^(terms2str simpl_p')) - else(); (t',simpl_p')) (* + uncond.rew. *) - else - (if ! trace_rewrite andalso i < ! depth - then writeln((idt"#"(i+1))^" asms false: "^(terms2str p')) - else(); raise STOP_REW_SUB (*dont go into subterms of cond*)) - end - in if perm lhs rhs andalso not (tless bdv (t',t)) (*ordered rewriting*) - then (if ! trace_rewrite andalso i < ! depth - then writeln((idt"#"i)^" not: \""^ - (term2str t)^"\" > \""^ - (term2str t')^"\"") else (); - raise NO_REWRITE ) - else ((*writeln("##@ rew_sub: (t''= "^(term2str t'')^ - ", p'' ="^(terms2str p'')^", true)");*) - (t'',p'',[],true)) - end - ) handle _ (*NO_REWRITE WN050820 causes diff.behav. in tests + MATCH!*) => - ((*writeln ("@@@ rew_sub gosub: t = "^(term2str t));*) - case t of - Const(s,T) => (Const(s,T),[],lrd,false) - | Free(s,T) => (Free(s,T),[],lrd,false) - | Var(n,T) => (Var(n,T),[],lrd,false) - | Bound i => (Bound i,[],lrd,false) - | Abs(s,T,body) => - let val (t', asms, lrd, rew) = - rew_sub thy i bdv tless rls put_asm (lrd@[D]) r body - in (Abs(s,T,t'), asms, [], rew) end - | t1 $ t2 => - let val (t2', asm2, lrd, rew2) = - rew_sub thy i bdv tless rls put_asm (lrd@[R]) r t2 - in if rew2 then (t1 $ t2', asm2, lrd, true) - else let val (t1', asm1, lrd, rew1) = - rew_sub thy i bdv tless rls put_asm (lrd@[L]) r t1 - in if rew1 then (t1' $ t2, asm1, lrd, true) - else (t1 $ t2,[], lrd, false) end - end) -(* val (cprems',rls)=([pre],prls); - rewrite__set_ thy i false rls pre; - *) -and eval__true thy i asms bdv rls = -(* val (thy, i, asms, bdv, rls) = (thy, (i+1), p', bdv, rls); - *) - if asms = [HOLogic.true_const] orelse asms = [] - then ([], true) else if asms = [HOLogic.false_const] then ([], false) - else let - fun chk indets [] = (indets, true)(*return asms<>True until false*) - | chk indets (a::asms) = -(* val (indets, (a::asms)) = ([], asms); - *) - (case rewrite__set_ thy (i+1) false bdv rls a of - NONE => (chk (indets @ [a]) asms) - | SOME (t, a') => - if t = HOLogic.true_const - then (chk (indets @ a') asms) - else if t = HOLogic.false_const then ([], false) - (*asm false .. thm not applied ^^^; continue until False vvv*) - else (chk (indets @ [t] @ a') asms)); - in chk [] asms end - -and rewrite__set_ _ _ __ Erls t = - raise error("rewrite__set_ called with 'Erls' for '"^term2str t^"'") - | rewrite__set_ thy i _ _ (rrls as Rrls _) t = - let val _= if ! trace_rewrite andalso i < ! depth - then writeln ((idt"#"i)^" rls: "^(id_rls rrls)^" on: "^ - (term2str t)) else () - val (t', asm, rew) = app_rev thy (i+1) rrls t - in if rew then SOME (t', distinct asm) - else NONE end - | rewrite__set_ thy i put_asm bdv rls ct = -(* val (thy, i, put_asm, bdv, rls, ct) = (thy, 1, bool, [], rls, term); - *) - let - datatype switch = Appl | Noap; - fun rew_once ruls asm ct Noap [] = (ct,asm) - | rew_once ruls asm ct Appl [] = - (case rls of Rls _ => rew_once ruls asm ct Noap ruls - | Seq _ => (ct,asm)) - | rew_once ruls asm ct apno (rul::thms) = -(* val (ruls, asm, ct, apno, (rul::thms)) = (ruls, [], ct, Noap, ruls); - val Thm (thmid, thm) = rul; - *) - case rul of - Thm (thmid, thm) => - (if !trace_rewrite andalso i < ! depth - then writeln((idt"#"(i+1))^" try thm: "^thmid) else (); - case rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) - ((#erls o rep_rls) rls) put_asm thm ct of - NONE => rew_once ruls asm ct apno thms - | SOME (ct',asm') => (if ! trace_rewrite andalso i < ! depth - then writeln((idt"="(i+1))^" rewrites to: "^ - (term2str ct')) else (); - rew_once ruls (union (op =) asm asm') ct' Appl (rul::thms))) - | Calc (cc as (op_,_)) => - (let val _= if !trace_rewrite andalso i < ! depth then - writeln((idt"#"(i+1))^" try calc: "^op_^"'") else (); - val ct = uminus_to_string ct - in case get_calculation_ thy cc ct of - NONE => ((*writeln "@@@ rewrite__set_: get_calculation_-> NONE";*) - rew_once ruls asm ct apno thms) - | SOME (thmid, thm') => - let - val pairopt = - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) - ((#erls o rep_rls) rls) put_asm thm' ct; - val _ = if pairopt <> NONE then () - else raise error("rewrite_set_, rewrite_ \""^ - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") - val _ = if ! trace_rewrite andalso i < ! depth - then writeln((idt"="(i+1))^" calc. to: "^ - (term2str ((fst o the) pairopt))) - else() - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end - end) -(* use"Scripts/rewrite.sml"; - @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) - | Cal1 (cc as (op_,_)) => - (let val _= if !trace_rewrite andalso i < ! depth then - writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else (); - val ct = uminus_to_string ct - in case get_calculation1_ thy cc ct of - NONE => (ct, asm) - | SOME (thmid, thm') => - let - val pairopt = - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls) - ((#erls o rep_rls) rls) put_asm thm' ct; - val _ = if pairopt <> NONE then () - else raise error("rewrite_set_, rewrite_ \""^ - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE") - val _ = if ! trace_rewrite andalso i < ! depth - then writeln((idt"="(i+1))^" cal1. to: "^ - (term2str ((fst o the) pairopt))) - else() - in the pairopt end - end) -(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) - | Rls_ rls' => - (case rewrite__set_ thy (i+1) put_asm bdv rls' ct of - SOME (t',asm') => rew_once ruls (union (op =) asm asm') t' Appl thms - | NONE => rew_once ruls asm ct apno thms); - - val ruls = (#rules o rep_rls) rls; - val _= if ! trace_rewrite andalso i < ! depth - then writeln ((idt"#"i)^" rls: "^(id_rls rls)^" on: "^ - (term2str ct)) else () - val (ct',asm') = rew_once ruls [] ct Noap ruls; - in if ct = ct' then NONE else SOME (ct', distinct asm') end - -and app_rev thy i rrls t = - let (*.check a (precond, pattern) of a rev-set; stops with 1st true.*) - fun chk_prepat thy erls [] t = true - | chk_prepat thy erls prepat t = - let fun chk (pres, pat) = - (let val subst: Type.tyenv * Envir.tenv = - Pattern.match thy (pat, t) - (Vartab.empty, Vartab.empty) - in snd (eval__true thy (i+1) - (map (Envir.subst_term subst) pres) - [] erls) - end) - handle _ => false - fun scan_ f [] = false (*scan_ NEVER called by []*) - | scan_ f (pp::pps) = if f pp then true - else scan_ f pps; - in scan_ chk prepat end; - - (*.apply the normal_form of a rev-set.*) - fun app_rev' thy (Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}) t = - if chk_prepat thy erls prepat t - then ((*writeln("### app_rev': t = "^(term2str t));*) - normal_form t) - else NONE; - - val opt = app_rev' thy rrls t - in case opt of - SOME (t', asm) => (t', asm, true) - | NONE => app_sub thy i rrls t - end -and app_sub thy i rrls t = - ((*writeln("### app_sub: subterm = "^(term2str t));*) - case t of - Const (s, T) => (Const(s, T), [], false) - | Free (s, T) => (Free(s, T), [], false) - | Var (n, T) => (Var(n, T), [], false) - | Bound i => (Bound i, [], false) - | Abs (s, T, body) => - let val (t', asm, rew) = app_rev thy i rrls body - in (Abs(s, T, t'), asm, rew) end - | t1 $ t2 => - let val (t2', asm2, rew2) = app_rev thy i rrls t2 - in if rew2 then (t1 $ t2', asm2, true) - else let val (t1', asm1, rew1) = app_rev thy i rrls t1 - in if rew1 then (t1' $ t2, asm1, true) - else (t1 $ t2, [], false) end - end); - - - -(*.rewriting without argument [] for rew_ord.*) -(*WN.11.6.03: shouldnt asm<>[] lead to false ????*) -fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls; - - -(*.rewriting without internal argument [] for rew_ord.*) -(* val (thy, rew_ord, erls, bool, thm, term) = - (thy, (assoc_rew_ord ro), rls', false, (assoc_thm' thy thm'), f); - val (thy, rew_ord, erls, bool, thm, term) = - (thy, rew_ord, erls, false, thm, t''); - *) -fun rewrite_ thy rew_ord erls bool thm term = - rewrite__ thy 1 [] rew_ord erls bool thm term; -fun rewrite_set_ thy bool rls term = -(* val (thy, bool, rls, term) = (thy, false, srls, t); - *) - rewrite__set_ thy 1 bool [] rls term; - - -fun subs'2subst thy (s:subs') = - (((map (apfst (term_of o the o (parse thy)))) - o (map (apsnd (term_of o the o (parse thy))))) s):subst; - -(*.variants of rewrite.*) -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, - thus the argument put_asm IS NOT NECESSARY -- FIXME*) -(* val (rew_ord,rls,put_asm,thm,ct)= - (e_rew_ord,poly_erls,false,num_str d1_isolate_add2,t); - *) -fun rewrite_inst_ (thy:theory) rew_ord (rls:rls) (put_asm:bool) - (subst:(term * term) list) (thm:thm) (ct:term) = - rewrite__ thy 1 subst rew_ord rls put_asm thm ct; - -fun rewrite_set_inst_ (thy:theory) - (put_asm:bool) (subst:(term * term) list) (rls:rls) (ct:term) = - (*let - val subst = subs'2subst thy subs'; - val subrls = instantiate_rls subs' rls - in*) rewrite__set_ thy 1 put_asm subst (*sub*)rls ct - (*end*); - -(* val (thy, ord, erls, subte, t) = (thy, dummy_ord, Erls, subte, t); - *) -(*.rewrite using a list of terms.*) -fun rewrite_terms_ thy ord erls subte t = - let (*val _=writeln("### rewrite_terms_ subte= '"^terms2str subte^"' ..."^ - term_detail2str (hd subte)^ - "### rewrite_terms_ t= '"^term2str t^"' ..."^ - term_detail2str t);*) - fun rew_ (t', asm') [] _ = (t', asm') - (* 1st val (t', asm', rules as r::rs, t) = (e_term, [], subte, t); - 2nd val (t', asm', rules as r::rs, t) = (t'', [], rules, t''); - rew_ (t', asm') (r::rs) t; - *) - | rew_ (t', asm') (rules as r::rs) t = - let val _ = writeln("rew_ "^term2str t); - val (t'', asm'', lrd, rew) = - rew_sub thy 1 [] ord erls false [] r t - in if rew - then (writeln("true rew_ "^term2str t''); - rew_ (t'', asm' @ asm'') rules t'') - else (writeln("false rew_ "^term2str t''); - rew_ (t', asm') rs t') - end - val (t'', asm'') = rew_ (e_term, []) subte t - in if t'' = e_term - then NONE else SOME (t'', asm'') - end; - - -(*. search ct for adjacent numerals and calculate them by operator isa_fn .*) -fun calculate_ thy isa_fn ct = - let val ct = uminus_to_string ct - in case get_calculation_ thy isa_fn ct of - NONE => NONE - | SOME (thmID, thm) => - (let val SOME (rew,_) = rewrite_ thy dummy_ord e_rls false thm ct - in SOME (rew,(thmID, thm)) end) - handle _ => error ("calculate_: "^thmID^" does not rewrite") - end; -(* -> val thy = InsSort.thy; -> val op_ = "le"; (* < *) -> val ct = (the o (parse thy)) - "foldr ins [#2] (if #1 < #3 then #1 # ins [] #3 else [#3, #1])"; -> calculate_ thy op_ ct; - SOME - ("foldr ins [#2] (if True then #1 # ins [] #3 else [#3, #1])", - "(#1 < #3) = True") : (cterm * thm) option *) - - -(* for test-printouts: -val _ = writeln("in rew_sub : "^( Syntax.string_of_term (thy2ctxt thy) t)) -val _ = writeln("in eval_true: prems= "^(commas (map (Syntax.string_of_term (thy2ctxt thy)) prems'))) -*) - - - - - - -fun get_rls_scr rs' = ((#scr o rep_rls o #2 o the o assoc') (!ruleset',rs')) - handle _ => raise error ("get_rls_scr: no script for "^rs'); - - -(*make_thm added to Pure/thm.ML*) -fun mk_thm thy str = - let val t = (term_of o the o (parse thy)) str - val t' = case t of - Const ("==>",_) $ _ $ _ => t - | _ => Trueprop $ t - in make_thm (cterm_of thy t') end; -(* - val str = "?r ^^^ 2 = ?r * ?r"; - val thm = realpow_twoI; - - val t1 = (#prop o rep_thm) (num_str thm); - val t2 = Trueprop $ ((term_of o the o (parse thy)) str); - t1 = t2; -val it = true : bool ... !!! - val th1 = (num_str thm); - val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e; - th1 = th2; -ML> val it = false : bool ... HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?! - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - val str = "k ~= 0 ==> m * k / (n * k) = m / n"; - val thm = real_mult_div_cancel2; - - val t1 = (#prop o rep_thm) (num_str thm); - val t2 = ((term_of o the o (parse thy)) str); - t1 = t2; -val it = false : bool ... Var .. Free - val th1 = (num_str thm); - val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e; - th1 = th2; -ML> val it = false : bool ... PLUS HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?! -*) - - -(*prints subgoal etc. -((goal thy);(topthm()) o ) str; *) -(*assume rejects scheme variables - assume ((cterm_of thy) (Trueprop $ - (term_of o the o (parse thy)) str)); *) - - -(* outcommented 18.11.xx, xx < 02 ------- -fun rul2rul' (Thm (thmid, thm)) = Thm'(thmid, string_of_thmI thm) - | rul2rul' (Calc op_) = Calc' op_; -fun rul'2rul thy (Thm'(thmid, ct')) = - Thm (thmid, mk_thm thy ct') - | rul'2rul thy' (Calc' op_) = Calc op_; - - -fun rls2rls' (Rls{preconds=preconds,rew_ord=rew_ord,rules=rules}:rls) = - Rls'{preconds'= map string_of_cterm preconds, - rew_ord' = fst rew_ord, - rules' = map rul2rul' rules}:rlsdat'; - -fun rls'2rls thy' (Rls'{preconds'=preconds,rew_ord'=rew_ord, - rules'=rules}:rlsdat') = - let val thy = the (assoc' (theory',thy')) - in Rls{preconds = map (the o (parse thy)) preconds, - rew_ord = (rew_ord, the (assoc'(rew_ord',rew_ord))), - rules = map (rul'2rul thy) rules}:rls end; -------- *) - -(*.get the theorem associated with the xstring-identifier; - if the identifier starts with "sym_" then swap lhs = rhs around = - (ATTENTION: "RS sym" attaches a [.] -- remove it with string_of_thmI); - identifiers starting with "#" come from Calc and - get a hand-made theorem (containing numerals only).*) -fun assoc_thm' (thy:theory) ((thmid, ct'):thm') = - (case explode thmid of - "s"::"y"::"m"::"_"::id => - if hd id = "#" - then mk_thm thy ct' - else ((num_str o (PureThy.get_thm thy)) (implode id)) RS sym - | id => - if hd id = "#" - then mk_thm thy ct' - else (num_str o (PureThy.get_thm thy)) thmid - ) handle _ => - raise error ("assoc_thm': '"^thmid^"' not in '"^ - (theory2domID thy)^"' (and parents)"); -(*> assoc_thm' Isac.thy ("sym_#mult_2_3","6 = 2 * 3"); -val it = "6 = 2 * 3" : thm - -> assoc_thm' Isac.thy ("real_add_zero_left",""); -val it = "0 + ?z = ?z" : thm - -> assoc_thm' Isac.thy ("sym_real_add_zero_left",""); -val it = "?t = 0 + ?t" [.] : thm - -> assoc_thm' HOL.thy ("sym_real_add_zero_left",""); -*** Unknown theorem(s) "real_add_zero_left" -*** assoc_thm': 'sym_real_add_zero_left' not in 'HOL.thy' (and parents) - uncaught exception ERROR*) - - -fun parse' (thy:theory') (ct:cterm') = - case parse ((the o assoc')(!theory',thy)) ct of - NONE => NONE - | SOME ct => SOME ((term2str (term_of ct)):cterm'); - - -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) -fun rewrite (thy':theory') (rew_ord:rew_ord') (rls:rls') - (put_asm:bool) (thm:thm') (ct:cterm') = -(* val (rew_ord, rls, thm, ct) = (rew_ord', id_rls rls', thm', f); - *) - let val thy = (the o assoc')(!theory',thy'); - in - case rewrite_ thy - ((the o assoc')(!rew_ord',rew_ord))((#2 o the o assoc')(!ruleset',rls)) - put_asm ((assoc_thm' thy) thm) - ((term_of o the o (parse thy)) ct) of - NONE => NONE - | SOME (t, ts) => SOME (term2str t, terms2str ts) - end; - -(* -val thy = "RatArith.thy"; -val rew_ord = "dummy_ord"; -> val rls = "eval_rls"; -val put_asm = true; -val thm = ("square_equation_left",""); -val ct = "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; - -val Zthy = ((the o assoc')(!theory',thy)); -val Zrew_ord = ((the o assoc')(!rew_ord',rew_ord)); -val Zrls = ((the o assoc')(!ruleset',rls)); -val Zput_asm = put_asm; -val Zthm = ((the o (assoc'_thm' thy)) thm); -val Zct = ((the o (parse ((the o assoc')(!theory',thy)))) ct); - -rewrite_ Zthy Zrew_ord Zrls Zput_asm Zthm Zct; - - use"Isa99/interface_ME_ISA.sml"; -*) - -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) -fun rewrite_set (thy':theory') (put_asm:bool) - (rls:rls') (ct:cterm') = - let val thy = (the o assoc')(!theory',thy'); - in - case rewrite_set_ thy put_asm ((#2 o the o assoc')(!ruleset',rls)) - ((term_of o the o (parse thy)) ct) of - NONE => NONE - | SOME (t, ts) => SOME (term2str t, terms2str ts) - end; - -(*evaluate list-expressions - should work on term, and stand in Isa99/rewrite-parse.sml, - but there list_rls <- eval_binop is not yet defined*) -(*fun eval_listexpr' ct = - let val rew = rewrite_set "ListG.thy" false "list_rls" ct; - in case rew of - SOME (res,_) => res - | NONE => ct end;-----------------30.9.02---*) -fun eval_listexpr_ thy srls t = -(* val (thy, srls, t) = - ((assoc_thy th), sr, (subst_atomic (upd_env_opt E (a,v)) t)); - *) - let val rew = rewrite_set_ thy false srls t; - in case rew of - SOME (res,_) => res - | NONE => t end; - - -fun get_calculation' (thy:theory') op_ (ct:cterm') = - case get_calculation_ ((the o assoc')(!theory',thy)) op_ - ((uminus_to_string o term_of o the o - (parse ((the o assoc')(!theory',thy)))) ct) of - NONE => NONE - | SOME (thmid, thm) => - SOME ((thmid, string_of_thmI thm):thm'); - -fun calculate (thy':theory') op_ (ct:cterm') = - let val thy = (the o assoc')(!theory',thy'); - in - case calculate_ thy op_ - ((term_of o the o (parse thy)) ct) of - NONE => NONE - | SOME (ct,(thmID,thm)) => - SOME (term2str ct, - (thmID, string_of_thmI thm):thm') - end; -(* -fun instantiate'' thy' subs ((thmid,ct'):thm') = - let val thmid_ = implode ("#"::(explode thmid)) (*see type thm'*) - in (thmid_, (string_of_thmI o (read_instantiate subs)) - ((the o (assoc_thm' thy')) (thmid_,ct'))):thm' end; - -fun instantiate_rls' thy' subs (rls:rls') = - rls2rls' (instantiate_rls subs ((the o (assoc_rls thy')) rls)):rlsdat'; - -... problem with these functions: -> val thm = mk_thm thy "(bdv + a = b) = (bdv = b - a)"; -val thm = "(bdv + a = b) = (bdv = b - a)" : thm -> show_types:=true; thm; -val it = "((bdv::'a) + (a::'a) = (b::'a)) = (bdv = b - a)" : thm -... and this doesn't match because of too general typing (?!) - and read_insitantiate doesn't instantiate the types (?!) -=== solutions: -(1) hard-coded type-instantiation ("'a", "RatArith.rat") -(2) instantiate', instantiate ... no help by isabelle-users@ !!! -=== conclusion: - rewrite_inst, rewrite_set_inst circumvent the problem, - according functions out-commented with 'instantiate'' -*) - -(* instantiate'' -fun instantiate'' thy' subs ((thmid,ct'):thm') = - let - val thmid_ = implode ("#"::(explode thmid)); (*see type thm'*) - val thy = (the o assoc')(!theory',thy'); - val typs = map (#T o rep_cterm o the o (parse thy)) - ((snd o split_list) subs); - val ctyps = map - ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o (parse thy)) - ((snd o split_list) subs); - -> val thy' = "RatArith.thy"; -> val subs = [("bdv","x::rat"),("zzz","z::nat")]; -> (the o (parse ((the o assoc')(!theory',thy')))) "x::rat"; -> (#T o rep_cterm o the o (parse ((the o assoc')(!theory',thy')))); - -> val ctyp = ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o - (parse ((the o assoc')(!theory',thy')))) "x::rat"; -> val bdv = (the o (parse thy)) "bdv"; -> val x = (the o (parse thy)) "x"; -> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add) - handle e => print_exn e; -uncaught exception THM - raised at: thm.ML:1085.18-1085.69 - thm.ML:1092.34 - goals.ML:536.61 - -> val bdv = (the o (parse thy)) "bdv::nat"; -> val x = (the o (parse thy)) "x::nat"; -> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add) - handle e => print_exn e; -uncaught exception THM - raised at: thm.ML:1085.18-1085.69 - thm.ML:1092.34 - goals.ML:536.61 - -> (instantiate' [SOME ctyp] [] isolate_bdv_add) - handle e => print_exn e; -uncaught exception TYPE - raised at: drule.ML:613.13-615.44 - goals.ML:536.61 - -> val repct = (rep_cterm o the o (parse ((the o assoc')(!theory',thy')))) "x::rat"; -*) - -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) -fun rewrite_inst (thy':theory') (rew_ord:rew_ord') (rls:rls') - (put_asm:bool) subs (thm:thm') (ct:cterm') = - let - val thy = (the o assoc')(!theory',thy'); - val thm = assoc_thm' thy thm; (*28.10.02*) - (*val subthm = read_instantiate subs ((assoc_thm' thy) thm)*) - in - case rewrite_ thy - ((the o assoc')(!rew_ord',rew_ord)) ((#2 o the o assoc')(!ruleset',rls)) - put_asm (*sub*)thm ((term_of o the o (parse thy)) ct) of - NONE => NONE - | SOME (ctm, ctms) => - SOME ((term2str ctm):cterm', (map term2str ctms):cterm' list) - end; - -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*) -fun rewrite_set_inst (thy':theory') (put_asm:bool) - subs' (rls:rls') (ct:cterm') = - let - val thy = (the o assoc')(!theory',thy'); - val rls = assoc_rls rls - val subst = subs'2subst thy subs' - (*val subrls = instantiate_rls subs ((the o assoc')(!ruleset',rls))*) - in case rewrite_set_inst_ thy put_asm subst (*sub*)rls - ((term_of o the o (parse thy)) ct) of - NONE => NONE - | SOME (t, ts) => SOME (term2str t, terms2str ts) - end; - - -(*vor check_elementwise: SqRoot_eval_rls .. wie *_simplify ?! TODO *) -fun eval_true' (thy':theory') (rls':rls') (Const ("True",_)) = true - - | eval_true' (thy':theory') (rls':rls') (t:term) = -(* val thy'="Isac.thy"; val rls'="eval_rls"; val t=hd pres'; - *) - let val ct' = term2str t; - in case rewrite_set thy' false rls' ct' of - SOME ("True",_) => true - | _ => false - end; -fun eval_true_ _ _ (Const ("True",_)) = true - | eval_true_ (thy':theory') rls t = - case rewrite_set_ (assoc_thy thy') false rls t of - SOME (Const ("True",_),_) => true - | _ => false; - -(* -val test_rls = - Rls{preconds = [], rew_ord = ("sqrt_right",sqrt_right), - rules = [Calc ("matches",eval_matches "") - ], - scr = Script ((term_of o the o (parse thy)) - "empty_script") - }:rls; - - - - rewrite_set_ Isac.thy eval_rls false test_rls - ((the o (parse thy)) "matches (?a = ?b) (x = #0)"); - val xxx = (term_of o the o (parse thy)) - "matches (?a = ?b) (x = #0)"; - eval_matches """" xxx thy; -SOME ("matches (?a = ?b) (x + #1 + #-1 * #2 = #0) = True", - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#))) - - - - rewrite_set_ Isac.thy eval_rls false eval_rls - ((the o (parse thy)) "contains_root (sqrt #0)"); -val it = SOME ("True",[]) : (cterm * cterm list) option - -*) - - -(*----------WN:16.5.03 stuff below considered illdesigned, thus coded from scratch in appl.sml fun check_elementwise -datatype det = TRUE | FALSE | INDET;(*FIXXME.WN:16.5.03 - introduced with quick-and-dirty code*) -fun determine dts = - let val false_indet = - filter_out ((curry op= TRUE) o (#1:det * term -> det)) dts - val ts = map (#2: det * term -> term) dts - in if nil = false_indet then (TRUE, ts) - else if nil = filter ((curry op= FALSE) o (#1:det * term -> det)) - false_indet - then (INDET, ts) - else (FALSE, ts) end; -(* val dts = [(INDET,e_term), (FALSE,HOLogic.false_const), - (INDET,e_term), (TRUE,HOLogic.true_const)]; - determine dts; -val it = - (FALSE, - [Const ("empty","'a"),Const ("False","bool"),Const ("empty","'a"), - Const ("True","bool")]) : det * term list*) - -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*) -if cs = [HOLogic.true_const] orelse cs = [] then (TRUE, []) - else if cs = [HOLogic.false_const] then (FALSE, cs) - else - let fun eval t = - let val taopt = rewrite__set_ thy 1 false [] rls t - in case taopt of - SOME (t,_) => - if t = HOLogic.true_const then (TRUE, t) - else if t = HOLogic.false_const then (FALSE, t) - else (INDET, t) - | NONE => (INDET, t) end - in (determine o (map eval)) cs end; -WN.16.5.0-------------------------------------------------------------*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/scrtools.sml --- a/src/Tools/isac/Scripts/scrtools.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,491 +0,0 @@ -(* tools which depend on Script.thy and thus are not in term_G.sml - (c) Walther Neuper 2000 - -use"Scripts/scrtools.sml"; -use"scrtools.sml"; -*) - - -fun is_reall_dsc - (Const(_,Type("fun",[Type("List.list", - [Type ("real",[])]),_]))) = true - | is_reall_dsc - (Const(_,Type("fun",[Type("List.list", - [Type ("real",[])]),_])) $ t) = true - | is_reall_dsc _ = false; -fun is_booll_dsc - (Const(_,Type("fun",[Type("List.list", - [Type ("bool",[])]),_]))) = true - | is_booll_dsc - (Const(_,Type("fun",[Type("List.list", - [Type ("bool",[])]),_])) $ t) = true - | is_booll_dsc _ = false; -(* -> val t = (term_of o the o (parse thy)) "relations"; -> atomtyp (type_of t); -*** Type (fun,[ -*** Type (List.list,[ -*** Type (bool,[]) -*** ] -*** Type (Tools.una,[]) -*** ] -> is_booll_dsc t; -val it = true : bool -> is_reall_dsc t; -val it = false : bool -*) - -fun is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_]))) = true - | is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_])) $ t) = true - (*WN:8.5.03: ??? ~~~~ ???*) - | is_list_dsc _ = false; -(* -> val t = str2term "someList"; -> is_list_dsc t; -val it = true : bool - -> val t = (term_of o the o (parse thy)) - "additional_relations [a=b,c=(d::real)]"; -> is_list_dsc t; -val it = true : bool -> is_list_dsc (head_of t); -val it = true : bool - -> val t = (term_of o the o (parse thy))"max_relation (A=#2*a*b-a^^^#2)"; -> is_list_dsc t; -val it = false : bool -> is_list_dsc (head_of t); -val it = false : bool -> val t = (term_of o the o (parse thy)) "testdscforlist"; -> is_list_dsc (head_of t); -val it = true : bool -*) - - -fun is_unl (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true - | is_unl _ = false; -(* -> val t = str2term "someList"; is_unl t; -val it = true : bool -> val t = (term_of o the o (parse thy)) "maximum"; -> is_unl t; -val it = false : bool -*) - -fun is_dsc (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) = true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.una",_)]))) = true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.str",_)]))) = true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) = true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))= true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.tobooll",_)])))= true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.unknow",_)])))= true - | is_dsc (Const(_,Type("fun",[_,Type("Tools.cpy",_)])))= true - | is_dsc _ = false; -fun is_dsc term = - (case (range_type o type_of) term of - Type("Tools.nam",_) => true - | Type("Tools.una",_) => true - | Type("Tools.unl",_) => true - | Type("Tools.str",_) => true - | Type("Tools.toreal",_) => true - | Type("Tools.toreall",_) => true - | Type("Tools.tobooll",_) => true - | Type("Tools.unknow",_) => true - | Type("Tools.cpy",_) => true - | _ => false) - handle Match => false; - - -(* -val t as t1 $ t2 = str2term "antiDerivativeName M_b"; -val Const (_, Type ("fun", [Type ("fun", _), Type ("Tools.una",[])])) $ _ = t; -is_dsc t1; - -> val t = (term_of o the o (parse thy)) "maximum"; -> is_dsc t; -val it = true : bool -> val t = (term_of o the o (parse thy)) "testdscforlist"; -> is_dsc t; -val it = true : bool - -> val t = (head_of o term_of o the o (parse thy)) "maximum A"; -> is_dsc t; -val it = true : bool -> val t = (head_of o term_of o the o (parse thy)) - "fixedValues [R=(R::real)]"; -> is_dsc t; -val it = true : bool -*) - - -(*make the term 'Subproblem (domID, pblID)' to a formula for frontend; - needs to be here after def. Subproblem in Script.thy*) -val t as (subpbl_t $ (pair_t $ Free (domID,_) $ pblID)) = - (term_of o the o (parse @{theory Script})) - "Subproblem (Isac,[equation,univar])"; -val t as (pbl_t $ _) = - (term_of o the o (parse @{theory Script})) - "Problem (Isac,[equation,univar])"; -val Free (_, ID_type) = (term_of o the o (parse @{theory Script})) "x::ID"; - - -fun subpbl domID pblID = - subpbl_t $ (pair_t $ Free (domID,ID_type) $ - (((list2isalist ID_type) o (map (mk_free ID_type))) pblID)); -(*> subpbl "Isac" ["equation","univar"] = t; -val it = true : bool *) - - -fun pblterm (domID:domID) (pblID:pblID) = - pbl_t $ (pair_t $ Free (domID,ID_type) $ - (((list2isalist ID_type) o (map (mk_free ID_type))) pblID)); - - -(**.construct scr-env from scr(created automatically) and Rewrite_Set.**) - -fun one_scr_arg (Const _ $ arg $ _) = arg - | one_scr_arg t = raise error ("one_scr_arg: called by "^(term2str t)); -fun two_scr_arg (Const _ $ a1 $ a2 $ _) = (a1, a2) - | two_scr_arg t = raise error ("two_scr_arg: called by "^(term2str t)); - - -(**.generate calc from a script.**) - -(*.instantiate a stactic or scriptexpr, and ev. attach (curried) argument -args: - E environment - v current value, is attached to curried stactics - stac stactic to be instantiated -precond: - not (a = NONE) /\ (v = e_term) /\ (stac curried, i.e. without last arg.) - this ........................ is the initialization for assy with l=[], - but the 1st stac is - (a) curried: then (a = SOME _), or - (b) not curried: then the values of the initialization are not used -.*) -datatype stacexpr = STac of term | Expr of term -fun rep_stacexpr (STac t ) = t - | rep_stacexpr (Expr t) = - raise error ("rep_stacexpr called with t= "^(term2str t)); - -type env = (term * term) list; - -(*update environment; t <> empty if coming from listexpr*) -fun upd_env (env:env) (v,t) = - let val env' = if t = e_term then env else overwrite (env,(v,t)); - (*val _= writeln("### upd_env: = "^(subst2str env'));*) - in env' end; - -(*.substitute the scripts environment in a leaf of the scripts parse-tree - and attach the curried argument of a tactic, if any. - a leaf is either a tactic or an 'exp' in 'let v = expr' - where 'exp' does not contain a tactic. -CAUTION: (1) currying with @@ requires 2 patterns for each tactic - (2) the non-curried version must return NONE for a - (3) non-matching patterns become an Expr by fall-through. -WN060906 quick and dirty fix: due to (2) a is returned, too.*) -fun subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ $ _ ))= - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ ))= - (a, (*in these cases we hope, that a = SOME _*) - STac (case a of SOME a' => (subst_atomic E (t $ a')) - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v - (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _))= - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ _ ))= - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ )) = - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v - (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v - (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ )) = - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ )) = - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v - (t as (Const("Script.Check'_elementwise",_) $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const("Script.Check'_elementwise",_) $ _ )) = - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_) $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_))) = (*t $ v*) - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - | subst_stacexpr E a v (t as (Const ("Script.SubProblem",_) $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Take",_) $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ $ _ )) = - (NONE, STac (subst_atomic E t)) - - | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ )) = - (a, STac (case a of SOME a' => subst_atomic E (t $ a') - | NONE => ((subst_atomic E t) $ v))) - - (*now all tactics are matched out and this leaf must be without a tactic*) - | subst_stacexpr E a v t = - (a, Expr (subst_atomic (case a of SOME a => upd_env E (a,v) - | NONE => E) t)); -(*> val t = str2term "SubProblem(Test_, [linear, univariate, equation, test], [Test, solve_linear]) [bool_ e_, real_ v_]"; -> subst_stacexpr [] NONE e_term t;*) - - -fun stacpbls (h $ body) = - let - fun scan ts (Const ("Let",_) $ e $ (Abs (v,T,b))) = - (scan ts e) @ (scan ts b) - | scan ts (Const ("If",_) $ c $ e1 $ e2) = (scan ts e1) @ (scan ts e2) - | scan ts (Const ("Script.While",_) $ c $ e $ _) = scan ts e - | scan ts (Const ("Script.While",_) $ c $ e) = scan ts e - | scan ts (Const ("Script.Repeat",_) $ e $ _) = scan ts e - | scan ts (Const ("Script.Repeat",_) $ e) = scan ts e - | scan ts (Const ("Script.Try",_) $ e $ _) = scan ts e - | scan ts (Const ("Script.Try",_) $ e) = scan ts e - | scan ts (Const ("Script.Or",_) $e1 $ e2 $ _) = - (scan ts e1) @ (scan ts e2) - | scan ts (Const ("Script.Or",_) $e1 $ e2) = - (scan ts e1) @ (scan ts e2) - | scan ts (Const ("Script.Seq",_) $e1 $ e2 $ _) = - (scan ts e1) @ (scan ts e2) - | scan ts (Const ("Script.Seq",_) $e1 $ e2) = - (scan ts e1) @ (scan ts e2) - | scan ts t = case subst_stacexpr [] NONE e_term t of - (_, STac _) => [t] | (_, Expr _) => [] - in (distinct o (scan [])) body end; - (*sc = Solve_root_equation ... -> val ts = stacpbls sc; -> writeln (terms2str thy ts); -["Rewrite square_equation_left True e_", - "Rewrite_Set SqRoot_simplify False e_", - "Rewrite_Set rearrange_assoc False e_", - "Rewrite_Set isolate_root False e_", - "Rewrite_Set norm_equation False e_", - "Rewrite_Set_Inst [(bdv, v_)] isolate_bdv False e_"] -*) - - - -fun is_calc (Const ("Script.Calculate",_) $ _) = true - | is_calc (Const ("Script.Calculate",_) $ _ $ _) = true - | is_calc _ = false; -fun op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_)) = op_ - | op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_) $ _) = op_ - | op_of_calc t = raise error ("op_of_calc called with"^term2str t); -(* - val Script sc = (#scr o rep_rls) Test_simplify; - val stacs = stacpbls sc; - - val calcs = filter is_calc stacs; - val ids = map op_of_calc calcs; - map (curry assoc1 (!calclist')) ids; - - (((map (curry assoc1 (!calclist'))) o (map op_of_calc) o - (filter is_calc) o stacpbls) sc):calc list; -*) - -(**.for automatic creation of scripts from rls.**) -(* naming of identifiers in scripts ???... -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t::'z) = t"; -((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o - (parse @{theory})) "(t't::'z) = t't"; -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_t::'z) = t_t"; -(* not accepted !!!...*) -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_::'z) = t_"; -((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o - (parse @{theory})) "(_t::'z) = _t"; -*) -((inst_abs @{theory}) o term_of o the o (parse @{theory})) -"Script Stepwise (t::'z) =\ - \(Repeat\ - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ - \ (Try (Repeat (Rewrite real_mult_commute False)))) \ - \ t_t)"; -val ScrStep $ _ $ _ = (*'z not affected by parse: 'a --> real*) - ((inst_abs @{theory}) o term_of o the o (parse @{theory})) - "Script Stepwise (t::'z) =\ - \(Repeat\ - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ - \ (Try (Repeat (Rewrite real_mult_commute False)))) \ - \ t_t)"; -(*WN060605 script-arg (t_::'z) and "Free (t_, 'a)" at end of body -are inconsistent !!!*) -val ScrStep_inst $ Term $ Bdv $ _=(*'z not affected by parse: 'a --> real*) - ((inst_abs @{theory}) o term_of o the o (parse @{theory})) - "Script Stepwise_inst (t::'z) (v::real) =\ - \(Repeat\ - \ ((Try (Repeat (Rewrite_Inst [(bdv,v)] real_diff_minus False))) @@ \ - \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_add_commute False))) @@\ - \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_mult_commute False)))) \ - \ t)"; -val Repeat $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Repeat (Rewrite real_diff_minus False t)"; -val Try $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Try (Rewrite real_diff_minus False t)"; -val Cal $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Calculate PLUS"; -val Ca1 $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Calculate1 PLUS"; -val Rew $ (Free (_,IDtype)) $ _ $ t = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Rewrite real_diff_minus False t"; -val Rew_Inst $ Subs $ _ $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Rewrite_Inst [(bdv,v)] real_diff_minus False"; -val Rew_Set $ _ $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Rewrite_Set real_diff_minus False"; -val Rew_Set_Inst $ _ $ _ $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - "Rewrite_Set_Inst [(bdv,v)] real_diff_minus False"; -val SEq $ _ $ _ $ _ = - ((inst_abs @{theory}) o term_of o the o (parseN @{theory})) - " ((Try (Repeat (Rewrite real_diff_minus False))) @@ \ - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \ - \ (Try (Repeat (Rewrite real_mult_commute False)))) t"; - -fun rule2stac _ (Thm (thmID, _)) = - Try $ (Repeat $ (Rew $ Free (thmID, IDtype) $ HOLogic.false_const)) - | rule2stac calc (Calc (c, _)) = - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) - | rule2stac calc (Cal1 (c, _)) = - Try $ (Repeat $ (Ca1 $ Free (assoc_calc (calc ,c), IDtype))) - | rule2stac _ (Rls_ rls) = - Try $ (Rew_Set $ Free (id_rls rls, IDtype) $ HOLogic.false_const); -(*val t = rule2stac [] (Thm ("real_diff_minus", num_str real_diff_minus)); -atomt t; term2str t; -val t = rule2stac calclist (Calc ("op +", eval_binop "#add_")); -atomt t; term2str t; -val t = rule2stac [] (Rls_ rearrange_assoc); -atomt t; term2str t; -*) -fun rule2stac_inst _ (Thm (thmID, _)) = - Try $ (Repeat $ (Rew_Inst $ Subs $ Free (thmID, IDtype) $ - HOLogic.false_const)) - | rule2stac_inst calc (Calc (c, _)) = - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) - | rule2stac_inst calc (Cal1 (c, _)) = - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype))) - | rule2stac_inst _ (Rls_ rls) = - Try $ (Rew_Set_Inst $ Subs $ Free (id_rls rls, IDtype) $ - HOLogic.false_const); -(*val t = rule2stac_inst [] (Thm ("real_diff_minus", num_str real_diff_minus)); -atomt t; term2str t; -val t = rule2stac_inst calclist (Calc ("op +", eval_binop "#add_")); -atomt t; term2str t; -val t = rule2stac_inst [] (Rls_ rearrange_assoc); -atomt t; term2str t; -*) - -(*for appropriate nesting take stacs in _reverse_ order*) -fun @@@ sts [s] = SEq $ s $ sts - | @@@ sts (s::ss) = @@@ (SEq $ s $ sts) ss; -fun @@ [stac] = stac - | @@ [s1, s2] = SEq $ s1 $ s2 (*---------vvv--*) - | @@ stacs = - let val s3::s2::ss = rev stacs - in @@@ (SEq $ s2 $ s3) ss end; -(* - val rules = (#rules o rep_rls) isolate_root; - val rs = map (rule2stac calclist) rules; - val tt = @@ rs; - atomt tt; writeln (term2str tt); - *) - -val contains_bdv = (not o null o (filter is_bdv) o ids2str o #prop o rep_thm); - -(*.does a rule contain a 'bdv'; descend recursively into Rls_.*) -fun contain_bdv [] = false - | contain_bdv (Thm (_, thm)::rs) = - if (not o contains_bdv) thm - then contain_bdv rs - else true - | contain_bdv (Calc _ ::rs) = contain_bdv rs - | contain_bdv (Cal1 _ ::rs) = contain_bdv rs - | contain_bdv (Rls_ rls ::rs) = - contain_bdv (get_rules rls) orelse contain_bdv rs - | contain_bdv (r::_) = - raise error ("contain_bdv called with ["^(id_rule r)^",...]"); - -fun rules2scr_Rls calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*) - if contain_bdv rules - then ScrStep_inst $ Term $ Bdv $ - (Repeat $ (((@@ o (map (rule2stac_inst calc))) rules) $ e_term)) - else ScrStep $ Term $ - (Repeat $ (((@@ o (map (rule2stac calc))) rules) $ e_term)); -(* val (calc, rules) = (!calclist', rules); - *) -fun rules2scr_Seq calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*) - if contain_bdv rules - then ScrStep_inst $ Term $ Bdv $ - (((@@ o (map (rule2stac_inst calc))) rules) $ e_term) - else ScrStep $ Term $ - (((@@ o (map (rule2stac calc))) rules) $ e_term); - -(*.prepare the input for an rls for use: - # generate a script for stepwise execution of the rls - # filter the operators for Calc out of the script - !!!use this function in ruleset' := !!! .*) -fun prep_rls Erls = raise error "prep_rls not impl. for Erls" - | prep_rls (Rls {id,preconds,rew_ord,erls,srls,calc,rules,...}) = - let val sc = (rules2scr_Rls (!calclist') rules) - in Rls {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls, - srls=srls, - calc = (*FIXXXME.040207 use also for met*) - ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o - (filter is_calc) o stacpbls) sc, - rules=rules, - scr = Script sc} end -(* val (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = add_new_c; - *) - | prep_rls (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = - let val sc = (rules2scr_Seq (!calclist') rules) - in Seq {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls, - srls=srls, - calc = ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o - (filter is_calc) o stacpbls) sc, - rules=rules, - scr = Script sc} end - | prep_rls (Rrls {id,...}) = - raise error ("prep_rls not required for Rrls \""^id^"\""); -(* - val Script sc = (#scr o rep_rls o prep_rls) isolate_root; - (writeln o term2str) sc; - val Script sc = (#scr o rep_rls o prep_rls) isolate_bdv; - (writeln o term2str) sc; - *) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Scripts/term_G.sml --- a/src/Tools/isac/Scripts/term_G.sml Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1343 +0,0 @@ -(* extends Isabelle/src/Pure/term.ML - (c) Walther Neuper 1999 - -use"Scripts/term_G.sml"; -use"term_G.sml"; -*) - -(* -> (cterm_of thy) a_term; -val it = "empty" : cterm *) - -(*2003 fun match thy t pat = - (snd (Pattern.match (Sign.tsig_of (sign_of thy)) (pat, t))) - handle _ => []; -fn : theory -> - Term.term -> Term.term -> (Term.indexname * Term.term) list*) -(*see src/Tools/eqsubst.ML fun clean_match*) -(*2003 fun matches thy tm pa = if match thy tm pa = [] then false else true;*) -fun matches thy tm pa = - (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true) - handle _ => false - -fun atomtyp t = (*see raw_pp_typ*) - let - fun ato n (Type (s,[])) = - ("\n*** "^indent n^"Type ("^s^",[])") - | ato n (Type (s,Ts)) = - ("\n*** "^indent n^"Type ("^s^",["^ atol (n+1) Ts) - - | ato n (TFree (s,sort)) = - ("\n*** "^indent n^"TFree ("^s^",["^ strs2str' sort) - - | ato n (TVar ((s,i),sort)) = - ("\n*** "^indent n^"TVar (("^s^","^ - string_of_int i ^ strs2str' sort) - and atol n [] = - ("\n*** "^indent n^"]") - | atol n (T::Ts) = (ato n T ^ atol n Ts) -(*in print (ato 0 t ^ "\n") end; TODO TUM10*) -in writeln(ato 0 t) end; - -(*Prog.Tutorial.p.34*) -local - fun pp_pair (x, y) = Pretty.list "(" ")" [x, y] - fun pp_list xs = Pretty.list "[" "]" xs - fun pp_str s = Pretty.str s - fun pp_qstr s = Pretty.quote (pp_str s) - fun pp_int i = pp_str (string_of_int i) - fun pp_sort S = pp_list (map pp_qstr S) - fun pp_constr a args = Pretty.block [pp_str a, Pretty.brk 1, args] -in -fun raw_pp_typ (TVar ((a, i), S)) = - pp_constr "TVar" (pp_pair (pp_pair (pp_qstr a, pp_int i), pp_sort S)) - | raw_pp_typ (TFree (a, S)) = - pp_constr "TFree" (pp_pair (pp_qstr a, pp_sort S)) - | raw_pp_typ (Type (a, tys)) = - pp_constr "Type" (pp_pair (pp_qstr a, pp_list (map raw_pp_typ tys))) -end -(* install -PolyML.addPrettyPrinter - (fn _ => fn _ => ml_pretty o Pretty.to_ML o raw_pp_typ); -de-install -PolyML.addPrettyPrinter - (fn _ => fn _ => ml_pretty o Pretty.to_ML o Proof_Display.pp_typ Pure.thy); -*) - -(* -> val T = (type_of o term_of o the o (parse thy)) "a::[real,int] => nat"; -> atomtyp T; -*** Type (fun,[ -*** Type (RealDef.real,[]) -*** Type (fun,[ -*** Type (IntDef.int,[]) -*** Type (nat,[]) -*** ] -*** ] -*) - -fun atomt t = - let fun ato (Const(a,T)) n = - ("\n*** "^indent n^"Const ("^a^")") - | ato (Free (a,T)) n = - ("\n*** "^indent n^"Free ("^a^", "^")") - | ato (Var ((a,ix),T)) n = - ("\n*** "^indent n^"Var (("^a^", "^(string_of_int ix)^"), "^")") - | ato (Bound ix) n = - ("\n*** "^indent n^"Bound "^(string_of_int ix)) - | ato (Abs(a,T,body)) n = - ("\n*** "^indent n^"Abs("^a^",..")^ato body (n+1) - | ato (f$t') n = (ato f n; ato t' (n+1)) - in writeln("\n*** -------------"^ ato t 0 ^"\n***") end; - -fun term_detail2str t = - let fun ato (Const (a, T)) n = - "\n*** "^indent n^"Const ("^a^", "^string_of_typ T^")" - | ato (Free (a, T)) n = - "\n*** "^indent n^"Free ("^a^", "^string_of_typ T^")" - | ato (Var ((a, ix), T)) n = - "\n*** "^indent n^"Var (("^a^", "^string_of_int ix^"), "^ - string_of_typ T^")" - | ato (Bound ix) n = - "\n*** "^indent n^"Bound "^string_of_int ix - | ato (Abs(a, T, body)) n = - "\n*** "^indent n^"Abs ("^a^", "^ - (string_of_typ T)^",.." - ^ato body (n + 1) - | ato (f $ t') n = ato f n^ato t' (n+1) - in "\n*** "^ato t 0^"\n***" end; -fun atomty t = (writeln o term_detail2str) t; - -fun term_str thy (Const(s,_)) = s - | term_str thy (Free(s,_)) = s - | term_str thy (Var((s,i),_)) = s^(string_of_int i) - | term_str thy (Bound i) = "B."^(string_of_int i) - | term_str thy (Abs(s,_,_)) = s - | term_str thy t = raise error("term_str not for "^term2str t); - -(*.contains the fst argument the second argument (a leave! of term).*) -fun contains_term (Abs(_,_,body)) t = contains_term body t - | contains_term (f $ f') t = - contains_term f t orelse contains_term f' t - | contains_term s t = t = s; -(*.contains the term a VAR(("*",_),_) ?.*) -fun contains_Var (Abs(_,_,body)) = contains_Var body - | contains_Var (f $ f') = contains_Var f orelse contains_Var f' - | contains_Var (Var _) = true - | contains_Var _ = false; -(* contains_Var (str2term "?z = 3") (*true*); - contains_Var (str2term "z = 3") (*false*); - *) - -(*fun int_of_str str = - let val ss = explode str - val str' = case ss of - "("::s => drop_last s | _ => ss - in case BasisLibrary.Int.fromString (implode str') of - SOME i => SOME i - | NONE => NONE end;*) -fun int_of_str str = - let val ss = explode str - val str' = case ss of - "("::s => drop_last s | _ => ss - in (SOME (Thy_Output.integer (implode str'))) handle _ => NONE end; -(* -> int_of_str "123"; -val it = SOME 123 : int option -> int_of_str "(-123)"; -val it = SOME 123 : int option -> int_of_str "#123"; -val it = NONE : int option -> int_of_str "-123"; -val it = SOME ~123 : int option -*) -fun int_of_str' str = - case int_of_str str of - SOME i => i - | NONE => raise TERM ("int_of_string: no int-string",[]); -val str2int = int_of_str'; - -fun is_numeral str = case int_of_str str of - SOME _ => true - | NONE => false; -val is_no = is_numeral; -fun is_num (Free (s,_)) = if is_numeral s then true else false - | is_num _ = false; -(*> -> is_num ((term_of o the o (parse thy)) "#1"); -val it = true : bool -> is_num ((term_of o the o (parse thy)) "#-1"); -val it = true : bool -> is_num ((term_of o the o (parse thy)) "a123"); -val it = false : bool -*) - -(*fun int_of_Free (Free (intstr, _)) = - (case BasisLibrary.Int.fromString intstr of - SOME i => i - | NONE => raise error ("int_of_Free ( "^ intstr ^", _)")) - | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");*) -fun int_of_Free (Free (intstr, _)) = (Thy_Output.integer intstr - handle _ => raise error ("int_of_Free ( "^ intstr ^", _)")) - | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )"); - -fun vars t = - let - fun scan vs (Const(s,T)) = vs - | scan vs (t as Free(s,T)) = if is_no s then vs else t::vs - | scan vs (t as Var((s,i),T)) = t::vs - | scan vs (Bound i) = vs - | scan vs (Abs(s,T,t)) = scan vs t - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) - in (distinct o (scan [])) t end; - -fun is_Free (Free _) = true - | is_Free _ = false; -fun is_fun_id (Const _) = true - | is_fun_id (Free _) = true - | is_fun_id _ = false; -fun is_f_x (f $ x) = is_fun_id f andalso is_Free x - | is_f_x _ = false; -(* is_f_x (str2term "q_0/2 * L * x") (*false*); - is_f_x (str2term "M_b x") (*true*); - *) -fun vars_str t = - let - fun scan vs (Const(s,T)) = vs - | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs - | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs - | scan vs (Bound i) = vs - | scan vs (Abs(s,T,t)) = scan vs t - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) - in (distinct o (scan [])) t end; - -fun ids2str t = - let - fun scan vs (Const(s,T)) = if is_no s then vs else s::vs - | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs - | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs - | scan vs (Bound i) = vs - | scan vs (Abs(s,T,t)) = scan (s::vs) t - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2) - in (distinct o (scan [])) t end; -fun is_bdv str = - case explode str of - "b"::"d"::"v"::_ => true - | _ => false; -fun is_bdv_ (Free (s,_)) = is_bdv s - | is_bdv_ _ = false; - -fun free2str (Free (s,_)) = s - | free2str t = raise error ("free2str not for "^ term2str t); -fun free2int (t as Free (s, _)) = ((str2int s) - handle _ => raise error ("free2int: "^term_detail2str t)) - | free2int t = raise error ("free2int: "^term_detail2str t); - -(*27.8.01: unused*) -fun var2free (t as Const(s,T)) = t - | var2free (t as Free(s,T)) = t - | var2free (Var((s,i),T)) = Free(s,T) - | var2free (t as Bound i) = t - | var2free (Abs(s,T,t)) = Abs(s,T,var2free t) - | var2free (t1 $ t2) = (var2free t1) $ (var2free t2); - -(*27.8.01: doesn't find some subterm ???!???*) -(*2010 Logic.varify !!!*) -fun free2var (t as Const(s,T)) = t - | free2var (t as Free(s,T)) = if is_no s then t else Var((s,0),T) - | free2var (t as Var((s,i),T)) = t - | free2var (t as Bound i) = t - | free2var (Abs(s,T,t)) = Abs(s,T,free2var t) - | free2var (t1 $ t2) = (free2var t1) $ (free2var t2); - - -fun mk_listT T = Type ("List.list", [T]); -fun list_const T = - Const("List.list.Cons", [T, mk_listT T] ---> mk_listT T); -(*28.8.01: TODO: get type from head of list: 1 arg less!!!*) -fun list2isalist T [] = Const("List.list.Nil",mk_listT T) - | list2isalist T (t::ts) = (list_const T) $ t $ (list2isalist T ts); -(* -> val tt = (term_of o the o (parse thy)) "R=(R::real)"; -> val TT = type_of tt; -> val ss = list2isalist TT [tt,tt,tt]; -> (cterm_of thy) ss; -val it = "[R = R, R = R, R = R]" : cterm *) - -fun isapair2pair (Const ("Pair",_) $ a $ b) = (a,b) - | isapair2pair t = - raise error ("isapair2pair called with "^term2str t); - -val listType = Type ("List.list",[Type ("bool",[])]); -fun isalist2list ls = - let - fun get es (Const("List.list.Cons",_) $ t $ ls) = get (t::es) ls - | get es (Const("List.list.Nil",_)) = es - | get _ t = - raise error ("isalist2list applied to NON-list '"^term2str t^"'") - in (rev o (get [])) ls end; -(* -> val il = str2term "[a=b,c=d,e=f]"; -> val l = isalist2list il; -> (writeln o terms2str) l; -["a = b","c = d","e = f"] - -> val il = str2term "ss___::bool list"; -> val l = isalist2list il; -[Free ("ss___", "bool List.list")] -*) - - -(*review Isabelle2009/src/HOL/Tools/hologic.ML*) -val prop = Type ("prop",[]); (* ~/Diss.99/Integers-Isa/tools.sml*) -val bool = Type ("bool",[]); (* 2002 Integ.int *) -val Trueprop = Const("Trueprop",bool-->prop); -fun mk_prop t = Trueprop $ t; -val true_as_term = Const("True",bool); -val false_as_term = Const("False",bool); -val true_as_cterm = cterm_of (theory "HOL") true_as_term; -val false_as_cterm = cterm_of (theory "HOL") false_as_term; - -infixr 5 -->; (*2002 /Pure/term.ML *) -infixr --->; (*2002 /Pure/term.ML *) -fun S --> T = Type("fun",[S,T]); (*2002 /Pure/term.ML *) -val op ---> = foldr (op -->); (*2002 /Pure/term.ML *) -fun list_implies ([], B) = B : term (*2002 /term.ML *) - | list_implies (A::AS, B) = Logic.implies $ A $ list_implies(AS,B); - - - -(** substitution **) - -fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = (* = thm.ML *) - match_bvs(s, t, if x="" orelse y="" then al - else (x,y)::al) - | match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al)) - | match_bvs(_,_,al) = al; -fun ren_inst(insts,prop,pat,obj) = (* = thm.ML *) - let val ren = match_bvs(pat,obj,[]) - fun renAbs(Abs(x,T,b)) = - Abs(case assoc_string(ren,x) of NONE => x - | SOME(y) => y, T, renAbs(b)) - | renAbs(f$t) = renAbs(f) $ renAbs(t) - | renAbs(t) = t - in subst_vars insts (if null(ren) then prop else renAbs(prop)) end; - - - - - - -fun dest_equals' (Const("op =",_) $ t $ u) = (t,u)(* logic.ML: Const("=="*) - | dest_equals' t = raise TERM("dest_equals'", [t]); -val lhs_ = (fst o dest_equals'); -val rhs_ = (snd o dest_equals'); - -fun is_equality (Const("op =",_) $ t $ u) = true (* logic.ML: Const("=="*) - | is_equality _ = false; -fun mk_equality (t,u) = (Const("op =",[type_of t,type_of u]--->bool) $ t $ u); -fun is_expliceq (Const("op =",_) $ (Free _) $ u) = true - | is_expliceq _ = false; -fun strip_trueprop (Const("Trueprop",_) $ t) = t - | strip_trueprop t = t; -(* | strip_trueprop t = raise TERM("strip_trueprop", [t]); -*) - -(*.(A1==>...An==>B) goes to (A1==>...An==>).*) -fun strip_imp_prems' (Const("==>", T) $ A $ t) = - let fun coll_prems As (Const("==>", _) $ A $ t) = - coll_prems (As $ (Logic.implies $ A)) t - | coll_prems As _ = SOME As - in coll_prems (Logic.implies $ A) t end - | strip_imp_prems' _ = NONE; (* logic.ML: term -> term list*) -(* - val thm = real_mult_div_cancel1; - val prop = (#prop o rep_thm) thm; - atomt prop; -*** ------------- -*** Const ( ==>) -*** . Const ( Trueprop) -*** . . Const ( Not) -*** . . . Const ( op =) -*** . . . . Var ((k, 0), ) -*** . . . . Const ( 0) -*** . Const ( Trueprop) -*** . . Const ( op =) *** ............. - val SOME t = strip_imp_prems' ((#prop o rep_thm) thm); - atomt t; -*** ------------- -*** Const ( ==>) -*** . Const ( Trueprop) -*** . . Const ( Not) -*** . . . Const ( op =) -*** . . . . Var ((k, 0), ) -*** . . . . Const ( 0) - - val thm = real_le_anti_sym; - val prop = (#prop o rep_thm) thm; - atomt prop; -*** ------------- -*** Const ( ==>) -*** . Const ( Trueprop) -*** . . Const ( op <=) -*** . . . Var ((z, 0), ) -*** . . . Var ((w, 0), ) -*** . Const ( ==>) -*** . . Const ( Trueprop) -*** . . . Const ( op <=) -*** . . . . Var ((w, 0), ) -*** . . . . Var ((z, 0), ) -*** . . Const ( Trueprop) -*** . . . Const ( op =) -*** ............. - val SOME t = strip_imp_prems' ((#prop o rep_thm) thm); - atomt t; -*** ------------- -*** Const ( ==>) -*** . Const ( Trueprop) -*** . . Const ( op <=) -*** . . . Var ((z, 0), ) -*** . . . Var ((w, 0), ) -*** . Const ( ==>) -*** . . Const ( Trueprop) -*** . . . Const ( op <=) -*** . . . . Var ((w, 0), ) -*** . . . . Var ((z, 0), ) -*) - -(*. (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch.*) -fun ins_concl (Const("==>", T) $ A $ t) B = Logic.implies $ A $ (ins_concl t B) - | ins_concl (Const("==>", T) $ A ) B = Logic.implies $ A $ B - | ins_concl t B = raise TERM("ins_concl", [t, B]); -(* - val thm = real_le_anti_sym; - val prop = (#prop o rep_thm) thm; - val concl = Logic.strip_imp_concl prop; - val SOME prems = strip_imp_prems' prop; - val prop' = ins_concl prems concl; - prop = prop'; - atomt prop; - atomt prop'; -*) - - -fun vperm (Var _, Var _) = true (*2002 Pure/thm.ML *) - | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t) - | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2) - | vperm (t, u) = (t = u); - -(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*) -fun mem_term (_, []) = false - | mem_term (t, t'::ts) = t aconv t' orelse mem_term(t,ts); -fun subset_term ([], ys) = true - | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term(xs, ys); -fun eq_set_term (xs, ys) = - xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs)); -(*a total, irreflexive ordering on index names*) -fun xless ((a,i), (b,j): indexname) = i insert_aterm(t,vars) - | Abs (_,_,body) => add_term_vars(body,vars) - | f$t => add_term_vars (f, add_term_vars(t, vars)) - | _ => vars; -fun term_vars t = add_term_vars(t,[]); - - -fun var_perm (t, u) = (*2002 Pure/thm.ML *) - vperm (t, u) andalso eq_set_term (term_vars t, term_vars u); - -(*2002 fun decomp_simp, Pure/thm.ML *) -fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs) - andalso not (is_Var lhs); - - -fun str_of_int n = - if n < 0 then "-"^((string_of_int o abs) n) - else string_of_int n; -(* -> str_of_int 1; -val it = "1" : string > str_of_int ~1; -val it = "-1" : string -*) - - -fun power b 0 = 1 - | power b n = - if n>0 then b*(power b (n-1)) - else raise error ("power "^(str_of_int b)^" "^(str_of_int n)); -(* -> power 2 3; -val it = 8 : int -> power ~2 3; -val it = ~8 : int -> power ~3 2; -val it = 9 : int -> power 3 ~2; -*) -fun gcd 0 b = b - | gcd a b = if a < b then gcd (b mod a) a - else gcd (a mod b) b; -fun sign n = if n < 0 then ~1 - else if n = 0 then 0 else 1; -fun sign2 n1 n2 = (sign n1) * (sign n2); - -infix dvd; -fun d dvd n = n mod d = 0; - -fun divisors n = - let fun pdiv ds d n = - if d=n then d::ds - else if d dvd n then pdiv (d::ds) d (n div d) - else pdiv ds (d+1) n - in pdiv [] 2 n end; - -divisors 30; -divisors 32; -divisors 60; -divisors 11; - -fun doubles ds = (* ds is ordered *) - let fun dbls ds [] = ds - | dbls ds [i] = ds - | dbls ds (i::i'::is) = if i=i' then dbls (i::ds) is - else dbls ds (i'::is) - in dbls [] ds end; -(*> doubles [2,3,4]; -val it = [] : int list -> doubles [2,3,3,5,5,7]; -val it = [5,3] : int list*) - -fun squfact 0 = 0 - | squfact 1 = 1 - | squfact n = foldl op* (1, (doubles o divisors) n); -(*> squfact 30; -val it = 1 : int -> squfact 32; -val it = 4 : int -> squfact 60; -val it = 2 : int -> squfact 11; -val it = 1 : int*) - - -fun dest_type (Type(T,[])) = T - | dest_type T = - (atomtyp T; - raise error ("... dest_type: not impl. for this type")); - -fun term_of_num ntyp n = Free (str_of_int n, ntyp); - -fun pairT T1 T2 = Type ("*", [T1, T2]); -(*> val t = str2term "(1,2)"; -> type_of t = pairT HOLogic.realT HOLogic.realT; -val it = true : bool -*) -fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2])); -(*> val t = str2term "(1,2)"; -> val Const ("Pair",pT) $ _ $ _ = t; -> pT = PairT HOLogic.realT HOLogic.realT; -val it = true : bool -*) -fun pairt t1 t2 = - Const ("Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2; -(*> val t = str2term "(1,2)"; -> val (t1, t2) = (str2term "1", str2term "2"); -> t = pairt t1 t2; -val it = true : bool*) - - -fun num_of_term (t as Free (s,_)) = - (case int_of_str s of - SOME s' => s' - | NONE => raise error ("num_of_term not for "^ term2str t)) - | num_of_term t = raise error ("num_of_term not for "^term2str t); - -fun mk_factroot op_(*=thy.sqrt*) T fact root = - Const ("op *", [T, T] ---> T) $ (term_of_num T fact) $ - (Const (op_, T --> T) $ term_of_num T root); -(* -val T = (type_of o term_of o the) (parse thy "#12::real"); -val t = mk_factroot "SqRoot.sqrt" T 2 3; -(cterm_of thy) t; -val it = "#2 * sqrt #3 " : cterm -*) -fun var_op_num v op_ optype ntyp n = - Const (op_, optype) $ v $ - Free (str_of_int n, ntyp); - -fun num_op_var v op_ optype ntyp n = - Const (op_,optype) $ - Free (str_of_int n, ntyp) $ v; - -fun num_op_num T1 T2 (op_,Top) n1 n2 = - Const (op_,Top) $ - Free (str_of_int n1, T1) $ Free (str_of_int n2, T2); -(* -> val t = num_op_num "Int" 3 4; -> atomty t; -> string_of_cterm ((cterm_of thy) t); -*) - -fun const_in str (Const _) = false - | const_in str (Free (s,_)) = if strip_thy s = str then true else false - | const_in str (Bound _) = false - | const_in str (Var _) = false - | const_in str (Abs (_,_,body)) = const_in str body - | const_in str (f$u) = const_in str f orelse const_in str u; -(* -> val t = (term_of o the o (parse thy)) "6 + 5 * sqrt 4 + 3"; -> const_in "sqrt" t; -val it = true : bool -> val t = (term_of o the o (parse thy)) "6 + 5 * 4 + 3"; -> const_in "sqrt" t; -val it = false : bool -*) - -(*used for calculating built in binary operations in Isabelle2002->Float.ML*) -(*fun calc "op +" (n1, n2) = n1+n2 - | calc "op -" (n1, n2) = n1-n2 - | calc "op *" (n1, n2) = n1*n2 - | calc "HOL.divide"(n1, n2) = n1 div n2 - | calc "Atools.pow"(n1, n2) = power n1 n2 - | calc op_ _ = raise error ("calc: operator = "^op_^" not defined");-----*) -fun calc_equ "op <" (n1, n2) = n1 < n2 - | calc_equ "op <=" (n1, n2) = n1 <= n2 - | calc_equ op_ _ = - raise error ("calc_equ: operator = "^op_^" not defined"); -fun sqrt (n:int) = if n < 0 then 0 - (*FIXME ~~~*) else (trunc o Math.sqrt o Real.fromInt) n; - -fun mk_thmid thmid op_ n1 n2 = - thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2); - -fun dest_binop_typ (Type("fun",[range,Type("fun",[arg2,arg1])])) = - (arg1,arg2,range) - | dest_binop_typ _ = raise error "dest_binop_typ: not binary"; -(* ----- -> val t = (term_of o the o (parse thy)) "#3^#4"; -> val hT = type_of (head_of t); -> dest_binop_typ hT; -val it = ("'a","nat","'a") : typ * typ * typ - ----- *) - - -(** transform binary numeralsstrings **) -(*Makarius 100308, hacked by WN*) -val numbers_to_string = - let - fun dest_num t = - (case try HOLogic.dest_number t of - SOME (T, i) => - (*if T = @{typ int} orelse T = @{typ real} then WN*) - SOME (Free (signed_string_of_int i, T)) - (*else NONE WN*) - | NONE => NONE); - - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b) - | to_str (t as (u1 $ u2)) = - (case dest_num t of - SOME t' => t' - | NONE => to_str u1 $ to_str u2) - | to_str t = perhaps dest_num t; - in to_str end - -(*.make uminus uniform: - Const ("uminus", _) $ Free ("2", "RealDef.real") --> Free ("-2", _) -to be used immediately before evaluation of numerals; -see Scripts/calculate.sml .*) -(*2002 fun(*app_num_tr'2 (Const("0",T)) = Free("0",T) - | app_num_tr'2 (Const("1",T)) = Free("1",T) - |*)app_num_tr'2 (t as Const("uminus",_) $ Free(s,T)) = - (case int_of_str s of SOME i => - if i > 0 then Free("-"^s,T) else Free(s,T) - | NONE => t) -(*| app_num_tr'2 (t as Const(s,T)) = t - | app_num_tr'2 (Const("Numeral.number_of",Type ("fun", [_, T])) $ t) = - Free(NumeralSyntax.dest_bin_str t, T) - | app_num_tr'2 (t as Free(s,T)) = t - | app_num_tr'2 (t as Var(n,T)) = t - | app_num_tr'2 (t as Bound i) = t -*)| app_num_tr'2 (Abs(s,T,body)) = Abs(s,T, app_num_tr'2 body) - | app_num_tr'2 (t1 $ t2) = (app_num_tr'2 t1) $ (app_num_tr'2 t2) - | app_num_tr'2 t = t; -*) -val uminus_to_string = - let - fun dest_num t = - (case t of - (Const ("HOL.uminus_class.uminus", _) $ Free (s, T)) => - (case int_of_str s of - SOME i => - SOME (Free (signed_string_of_int (~1 * i), T)) - | NONE => NONE) - | _ => NONE); - - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b) - | to_str (t as (u1 $ u2)) = - (case dest_num t of - SOME t' => t' - | NONE => to_str u1 $ to_str u2) - | to_str t = perhaps dest_num t; - in to_str end; - - -(*2002 fun num_str thm = - let - val {sign_ref = sign_ref, der = der, maxidx = maxidx, - shyps = shyps, hyps = hyps, (*tpairs = tpairs,*) prop = prop} = - rep_thm_G thm; - val prop' = app_num_tr'1 prop; - in assbl_thm sign_ref der maxidx shyps hyps (*tpairs*) prop' end;*) -fun num_str thm = - let val (deriv, - {thy_ref = thy_ref, tags = tags, maxidx = maxidx, shyps = shyps, - hyps = hyps, tpairs = tpairs, prop = prop}) = rep_thm_G thm - val prop' = numbers_to_string prop; - in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end; - -fun get_thm' xstring = (*?covers 2009 Thm?!, replaces 2002 fun get_thm : -val it = fn : theory -> xstring -> Thm.thm*) - Thm (xstring, - num_str (ProofContext.get_thm (thy2ctxt' "Isac") xstring)); - -(** get types of Free and Abs for parse' **) -(*11.1.00: not used, fix-typed +,*,-,^ instead *) - -val dummyT = Type ("dummy",[]); -val dummyT = TVar (("DUMMY",0),[]); - -(* assumes only 1 type for numerals - and different identifiers for Const, Free and Abs *) -fun get_types t = - let - fun get ts (Const(s,T)) = (s,T)::ts - | get ts (Free(s,T)) = if is_no s - then ("#",T)::ts else (s,T)::ts - | get ts (Var(n,T)) = ts - | get ts (Bound i) = ts - | get ts (Abs(s,T,body)) = get ((s,T)::ts) body - | get ts (t1 $ t2) = (get ts t1) @ (get ts t2) - in distinct (get [] t) end; -(* -val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; -get_types t; -*) - -(*11.1.00: not used, fix-typed +,*,-,^ instead *) -fun set_types al (Const(s,T)) = - (case assoc (al,s) of - SOME T' => Const(s,T') - | NONE => (warning ("set_types: no type for "^s); Const(s,dummyT))) - | set_types al (Free(s,T)) = - if is_no s then - (case assoc (al,"#") of - SOME T' => Free(s,T') - | NONE => (warning ("set_types: no type for numerals"); Free(s,T))) - else (case assoc (al,s) of - SOME T' => Free(s,T') - | NONE => (warning ("set_types: no type for "^s); Free(s,T))) - | set_types al (Var(n,T)) = Var(n,T) - | set_types al (Bound i) = Bound i - | set_types al (Abs(s,T,body)) = - (case assoc (al,s) of - SOME T' => Abs(s,T', set_types al body) - | NONE => (warning ("set_types: no type for "^s); - Abs(s,T, set_types al body))) - | set_types al (t1 $ t2) = (set_types al t1) $ (set_types al t2); -(* -val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)"; -val al = get_types t; - -val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4"; -atomty t; (* 'a *) -val t' = set_types al t; -atomty t'; (*real*) -(cterm_of thy) t'; -val it = "x = #0 + #-1 * #-4" : cterm - -val t = (term_of o the o (parse thy)) - "#5 * x + x ^^^ #2 = (#2 + x) ^^^ #2"; -atomty t; -val t' = set_types al t; -atomty t'; -(cterm_of thy) t'; -uncaught exception TYPE (*^^^ is new, NOT in al*) -*) - - -(** from Descript.ML **) - -(** decompose an isa-list to an ML-list - i.e. [] belong to the meta-language, too **) - -fun is_list ((Const("List.list.Cons",_)) $ _ $ _) = true - | is_list _ = false; -(* val (SOME ct) = parse thy "lll::real list"; -> val ty = (#t o rep_cterm) ct; -> is_list ty; -val it = false : bool -> val (SOME ct) = parse thy "[lll]"; -> val ty = (#t o rep_cterm) ct; -> is_list ty; -val it = true : bool *) - - - -fun mk_Free (s,T) = Free(s,T); -fun mk_free T s = Free(s,T); - -(*instantiate let; necessary for ass_up*) -fun inst_abs thy (Const sT) = Const sT - | inst_abs thy (Free sT) = Free sT - | inst_abs thy (Bound n) = Bound n - | inst_abs thy (Var iT) = Var iT - | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) = - let val (v',b') = variant_abs (v,T2,b); (*fun variant_abs: term.ML*) - in Const ("Let",T1) $ inst_abs thy e $ (Abs (v',T2,inst_abs thy b')) end - | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2 - | inst_abs thy t = - (writeln("inst_abs: unchanged t= "^ term2str t); - t); -(*val scr as (Script sc) = Script ((term_of o the o (parse thy)) - "Script Testeq (e_::bool) = \ - \While (contains_root e_) Do \ - \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False e_)); \ - \ e_ = Try (Repeat (Rewrite square_equation_left True e_)) \ - \ in Try (Repeat (Rewrite radd_0 False e_))) "); -ML> atomt sc; -*** Const ( Script.Testeq) -*** . Free ( e_, ) -*** . Const ( Script.While) -*** . . Const ( RatArith.contains'_root) -*** . . . Free ( e_, ) -*** . . Const ( Let) -*** . . . Const ( Script.Try) -*** . . . . Const ( Script.Repeat) -*** . . . . . Const ( Script.Rewrite) -*** . . . . . . Free ( rroot_square_inv, ) -*** . . . . . . Const ( False) -*** . . . . . . Free ( e_, ) -*** . . . Abs( e_,.. -*** . . . . Const ( Let) -*** . . . . . Const ( Script.Try) -*** . . . . . . Const ( Script.Repeat) -*** . . . . . . . Const ( Script.Rewrite) -*** . . . . . . . . Free ( square_equation_left, ) -*** . . . . . . . . Const ( True) -*** . . . . . . . . Bound 0 <-- !!! -*** . . . . . Abs( e_,.. -*** . . . . . . Const ( Script.Try) -*** . . . . . . . Const ( Script.Repeat) -*** . . . . . . . . Const ( Script.Rewrite) -*** . . . . . . . . . Free ( radd_0, ) -*** . . . . . . . . . Const ( False) -*** . . . . . . . . . Bound 0 <-- !!! -val it = () : unit -ML> atomt (inst_abs thy sc); -*** Const ( Script.Testeq) -*** . Free ( e_, ) -*** . Const ( Script.While) -*** . . Const ( RatArith.contains'_root) -*** . . . Free ( e_, ) -*** . . Const ( Let) -*** . . . Const ( Script.Try) -*** . . . . Const ( Script.Repeat) -*** . . . . . Const ( Script.Rewrite) -*** . . . . . . Free ( rroot_square_inv, ) -*** . . . . . . Const ( False) -*** . . . . . . Free ( e_, ) -*** . . . Abs( e_,.. -*** . . . . Const ( Let) -*** . . . . . Const ( Script.Try) -*** . . . . . . Const ( Script.Repeat) -*** . . . . . . . Const ( Script.Rewrite) -*** . . . . . . . . Free ( square_equation_left, ) -*** . . . . . . . . Const ( True) -*** . . . . . . . . Free ( e_, ) <-- !!! -*** . . . . . Abs( e_,.. -*** . . . . . . Const ( Script.Try) -*** . . . . . . . Const ( Script.Repeat) -*** . . . . . . . . Const ( Script.Rewrite) -*** . . . . . . . . . Free ( radd_0, ) -*** . . . . . . . . . Const ( False) -*** . . . . . . . . . Free ( e_, ) <-- ZUFALL vor 5.03!!! -val it = () : unit*) - - - - -fun inst_abs thy (Const sT) = Const sT - | inst_abs thy (Free sT) = Free sT - | inst_abs thy (Bound n) = Bound n - | inst_abs thy (Var iT) = Var iT - | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) = - let val b' = subst_bound (Free(v,T2),b); - (*fun variant_abs: term.ML*) - in Const ("Let",T1) $ inst_abs thy e $ (Abs (v,T2,inst_abs thy b')) end - | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2 - | inst_abs thy t = - (writeln("inst_abs: unchanged t= "^ term2str t); - t); -(*val scr = - "Script Make_fun_by_explicit (f_::real) (v_::real) (eqs_::bool list) = \ - \ (let h_ = (hd o (filterVar f_)) eqs_; \ - \ e_1 = hd (dropWhile (ident h_) eqs_); \ - \ vs_ = dropWhile (ident f_) (Vars h_); \ - \ v_1 = hd (dropWhile (ident v_) vs_); \ - \ (s_1::bool list)=(SubProblem(DiffApp_,[univar,equation],[no_met])\ - \ [bool_ e_1, real_ v_1])\ - \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)"; -> val ttt = (term_of o the o (parse thy)) scr; -> writeln(term2str ttt); -> atomt ttt; -*** ------------- -*** Const ( DiffApp.Make'_fun'_by'_explicit) -*** . Free ( f_, ) -*** . Free ( v_, ) -*** . Free ( eqs_, ) -*** . Const ( Let) -*** . . Const ( Fun.op o) -*** . . . Const ( List.hd) -*** . . . Const ( DiffApp.filterVar) -*** . . . . Free ( f_, ) -*** . . . Free ( eqs_, ) -*** . . Abs( h_,.. -*** . . . Const ( Let) -*** . . . . Const ( List.hd) -*** . . . . . Const ( List.dropWhile) -*** . . . . . . Const ( Atools.ident) -*** . . . . . . . Bound 0 <---- Free ( h_, ) -*** . . . . . . Free ( eqs_, ) -*** . . . . Abs( e_1,.. -*** . . . . . Const ( Let) -*** . . . . . . Const ( List.dropWhile) -*** . . . . . . . Const ( Atools.ident) -*** . . . . . . . . Free ( f_, ) -*** . . . . . . . Const ( Tools.Vars) -*** . . . . . . . . Bound 1 <---- Free ( h_, ) -*** . . . . . . Abs( vs_,.. -*** . . . . . . . Const ( Let) -*** . . . . . . . . Const ( List.hd) -*** . . . . . . . . . Const ( List.dropWhile) -*** . . . . . . . . . . Const ( Atools.ident) -*** . . . . . . . . . . . Free ( v_, ) -*** . . . . . . . . . . Bound 0 <---- Free ( vs_, ) -*** . . . . . . . . Abs( v_1,.. -*** . . . . . . . . . Const ( Let) -*** . . . . . . . . . . Const ( Script.SubProblem) -*** . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . Free ( DiffApp_, ) -*** . . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . Free ( univar, ) -*** . . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . . Free ( equation, ) -*** . . . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . Free ( no_met, ) -*** . . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . Const ( Script.bool_) -*** . . . . . . . . . . . . . Bound 2 <----- Free ( e_1, ) -*** . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . Const ( Script.real_) -*** . . . . . . . . . . . . . . Bound 0 <----- Free ( v_1, ) -*** . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . Abs( s_1,.. -*** . . . . . . . . . . . Const ( Script.Substitute) -*** . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . . . Bound 1 <----- Free ( v_1, ) -*** . . . . . . . . . . . . . . Const ( Fun.op o) -*** . . . . . . . . . . . . . . . Const ( Tools.rhs) -*** . . . . . . . . . . . . . . . Const ( List.hd) -*** . . . . . . . . . . . . . . . Bound 0 <----- Free ( s_1, ) -*** . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . . Bound 4 <----- Free ( h_, ) - -> val ttt' = inst_abs thy ttt; -> writeln(term2str ttt'); -Script Make_fun_by_explicit f_ v_ eqs_ = - ... as above ... -> atomt ttt'; -*** ------------- -*** Const ( DiffApp.Make'_fun'_by'_explicit) -*** . Free ( f_, ) -*** . Free ( v_, ) -*** . Free ( eqs_, ) -*** . Const ( Let) -*** . . Const ( Fun.op o) -*** . . . Const ( List.hd) -*** . . . Const ( DiffApp.filterVar) -*** . . . . Free ( f_, ) -*** . . . Free ( eqs_, ) -*** . . Abs( h_,.. -*** . . . Const ( Let) -*** . . . . Const ( List.hd) -*** . . . . . Const ( List.dropWhile) -*** . . . . . . Const ( Atools.ident) -*** . . . . . . . Free ( h_, ) <---- Bound 0 -*** . . . . . . Free ( eqs_, ) -*** . . . . Abs( e_1,.. -*** . . . . . Const ( Let) -*** . . . . . . Const ( List.dropWhile) -*** . . . . . . . Const ( Atools.ident) -*** . . . . . . . . Free ( f_, ) -*** . . . . . . . Const ( Tools.Vars) -*** . . . . . . . . Free ( h_, ) <---- Bound 1 -*** . . . . . . Abs( vs_,.. -*** . . . . . . . Const ( Let) -*** . . . . . . . . Const ( List.hd) -*** . . . . . . . . . Const ( List.dropWhile) -*** . . . . . . . . . . Const ( Atools.ident) -*** . . . . . . . . . . . Free ( v_, ) -*** . . . . . . . . . . Free ( vs_, ) <---- Bound 0 -*** . . . . . . . . Abs( v_1,.. -*** . . . . . . . . . Const ( Let) -*** . . . . . . . . . . Const ( Script.SubProblem) -*** . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . Free ( DiffApp_, ) -*** . . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . Free ( univar, ) -*** . . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . . Free ( equation, ) -*** . . . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . . Free ( no_met, ) -*** . . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . Const ( Script.bool_) -*** . . . . . . . . . . . . . Free ( e_1, ) <----- Bound 2 -*** . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . Const ( Script.real_) -*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 0 -*** . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . Abs( s_1,.. -*** . . . . . . . . . . . Const ( Script.Substitute) -*** . . . . . . . . . . . . Const ( List.list.Cons) -*** . . . . . . . . . . . . . Const ( Pair) -*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 1 -*** . . . . . . . . . . . . . . Const ( Fun.op o) -*** . . . . . . . . . . . . . . . Const ( Tools.rhs) -*** . . . . . . . . . . . . . . . Const ( List.hd) -*** . . . . . . . . . . . . . . . Free ( s_1, ) <----- Bound 0 -*** . . . . . . . . . . . . . Const ( List.list.Nil) -*** . . . . . . . . . . . . Free ( h_, ) <----- Bound 4 - -Note numbering of de Bruijn indexes ! - -Script Make_fun_by_explicit f_ v_ eqs_ = - let h_ = (hd o filterVar f_) eqs_; - e_1 = hd (dropWhile (ident h_ BOUND_0) eqs_); - vs_ = dropWhile (ident f_) (Vars h_ BOUND_1); - v_1 = hd (dropWhile (ident v_) vs_ BOUND_0); - s_1 = - SubProblem (DiffApp_, [univar, equation], [no_met]) - [bool_ e_1 BOUND_2, real_ v_1 BOUND_0] - in Substitute [(v_1 BOUND_1 = (rhs o hd) s_1 BOUND_0)] h_ BOUND_4 -*) - - -fun T_a2real (Type (s, [])) = - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, []) - | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts) - | T_a2real (TFree (s, srt)) = - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt) - | T_a2real (TVar (("DUMMY",_),srt)) = HOLogic.realT; - -(*FIXME .. fixes the type (+see Typefix.thy*) -fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T)) - | typ_a2real (Free( s, T)) = (Free( s, T_a2real T)) - | typ_a2real (Var( n, T)) = (Var( n, T_a2real T)) - | typ_a2real (Bound i) = (Bound i) - | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t) - | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2); -(* -----------------6.8.02--------------------------------------------------- - val str = "1"; - val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[]))); - atomty (term_of t); -*** ------------- -*** Const ( 1, 'a) - val t = (app_num_tr' o term_of) t; - atomty t; -*** ------------- -*** Const ( 1, 'a) - val t = typ_a2real t; - atomty t; -*** ------------- -*** Const ( 1, real) - - val str = "2"; - val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[]))); - atomty (term_of t); -*** ------------- -*** Const ( Numeral.number_of, bin => 'a) -*** . Const ( Numeral.bin.Bit, [bin, bool] => bin) -*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin) -*** . . . Const ( Numeral.bin.Pls, bin) -*** . . . Const ( True, bool) -*** . . Const ( False, bool) - val t = (app_num_tr' o term_of) t; - atomty t; -*** ------------- -*** Free ( 2, 'a) - val t = typ_a2real t; - atomty t; -*** ------------- -*** Free ( 2, real) -----------------6.8.02--------------------------------------------------- - - -> val str = "R"; -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); -val t = Free ("R","?DUMMY") : term -> val t' = typ_a2real t; -> (cterm_of thy) t'; -val it = "R::RealDef.real" : cterm - -> val str = "R=R"; -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); -> atomty (typ_a2real t); -*** ------------- -*** Const ( op =, [RealDef.real, RealDef.real] => bool) -*** Free ( R, RealDef.real) -*** Free ( R, RealDef.real) -> val t' = typ_a2real t; -> (cterm_of thy) t'; -val it = "(R::RealDef.real) = R" : cterm - -> val str = "fixed_values [R=R]"; -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[])))); -> val t' = typ_a2real t; -> (cterm_of thy) t'; -val it = "fixed_values [(R::RealDef.real) = R]" : cterm -*) - -(*TODO.WN0609: parse should return a term or a string - (or even more comprehensive datastructure for error-messages) - i.e. in wrapping with SOME term or NONE the latter is not sufficient*) -(*2002 fun parseold thy str = - (let - val sgn = sign_of thy; - val t = ((*typ_a2real o*) app_num_tr'1 o term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); - in SOME (cterm_of sgn t) end) - handle _ => NONE;*) - - - -fun parseold thy str = - (let val t = ((*typ_a2real o*) numbers_to_string) - (Syntax.read_term_global thy str) - in SOME (cterm_of thy t) end) - handle _ => NONE; -(*2002 fun parseN thy str = - (let - val sgn = sign_of thy; - val t = ((*typ_a2real o app_num_tr'1 o*) term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); - in SOME (cterm_of sgn t) end) - handle _ => NONE;*) -fun parseN thy str = - (let val t = (*(typ_a2real o numbers_to_string)*) - (Syntax.read_term_global thy str) - in SOME (cterm_of thy t) end) - handle _ => NONE; -(*2002 fun parse thy str = - (let - val sgn = sign_of thy; - val t = (typ_a2real o app_num_tr'1 o term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))); - in SOME (cterm_of sgn t) end) (*FIXXXXME 10.8.02: return term !!!*) - handle _ => NONE;*) -(*2010 fun parse thy str = - (let val t = (typ_a2real o app_num_tr'1) (Syntax.read_term_global thy str) - in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*) - handle _ => NONE;*) -fun parse thy str = - (let val t = (typ_a2real o numbers_to_string) - (Syntax.read_term_global thy str) - in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*) - handle _ => NONE; - -(* 10.8.02: for this reason we still have ^^^-------------------- - val thy = SqRoot.thy; - val str = "(1::real) ^ (2::nat)"; - val sgn = sign_of thy; - val ct = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e =>print_exn e; -(*1*)"(1::real) ^ 2"; - atomty (term_of ct); -*** ------------- -*** Const ( Nat.power, [real, nat] => real) -*** . Const ( 1, real) -*** . Const ( Numeral.number_of, bin => nat) -*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin) -*** . . . Const ( Numeral.bin.Bit, [bin, bool] => bin) -*** . . . . Const ( Numeral.bin.Pls, bin) -*** . . . . Const ( True, bool) -*** . . . Const ( False, bool) - val t = ((app_num_tr' o term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; - val ct = (cterm_of sgn t) handle e => print_exn e; -(*2*)"(1::real) ^ (2::nat)"; - atomty (term_of ct); -*** ------------- -*** Const ( Nat.power, [real, nat] => real) -*** . Free ( 1, real) -*** . Free ( 2, nat) (*1*) Const("2",_) (*2*) Free("2",_) - - - val str = "(2::real) ^ (2::nat)"; - val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e; -val t = "(2::real) ^ 2" : cterm - val t = ((app_num_tr' o term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; - val ct = (cterm_of sgn t) handle e => print_exn e; -Variable "2" has two distinct types -real -nat -uncaught exception TYPE - raised at: sign.ML:672.26-673.56 - goals.ML:1100.61 - - - val str = "(3::real) ^ (2::nat)"; - val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e; -val t = "(3::real) ^ 2" : cterm - val t = ((app_num_tr' o term_of) - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e; - val ct = (cterm_of sgn t) handle e => print_exn e; -val ct = "(3::real) ^ (2::nat)" : cterm - - -Conclusion: The type inference allows different types - for one and the same Numeral.number_of - BUT the type inference doesn't allow - Free ( 2, real) and Free ( 2, nat) within one term ---------------- ~~~~ ~~~ *) -(* -> val (SOME ct) = parse thy "(-#5)^^^#3"; -> atomty (term_of ct); -*** ------------- -*** Const ( Nat.op ^, ['a, nat] => 'a) -*** Const ( uminus, 'a => 'a) -*** Free ( #5, 'a) -*** Free ( #3, nat) -> val (SOME ct) = parse thy "R=R"; -> atomty (term_of ct); -*** ------------- -*** Const ( op =, [real, real] => bool) -*** Free ( R, real) -*** Free ( R, real) - -THIS IS THE OUTPUT FOR VERSION (3) above at typ_a2real !!!!! -*** ------------- -*** Const ( op =, [RealDef.real, RealDef.real] => bool) -*** Free ( R, RealDef.real) -*** Free ( R, RealDef.real) *) - -(*version for testing local to theories*) -fun str2term_ thy str = (term_of o the o (parse thy)) str; -fun str2term str = (term_of o the o (parse (theory "Isac"))) str; -fun strs2terms ss = map str2term ss; -fun str2termN str = (term_of o the o (parseN (theory "Isac"))) str; - -(*+ makes a substitution from the output of Pattern.match +*) -(*fun mk_subs ((id, _):indexname, t:term) = (Free (id,type_of t), t);*) -fun mk_subs (subs: ((string * int) * (Term.typ * Term.term)) list) = -let fun mk_sub ((id, _), (ty, tm)) = (Free (id, ty), tm) in -map mk_sub subs end; - -val atomthm = atomt o #prop o rep_thm; - -(*.instantiate #prop thm with bound variables (as Free).*) -fun inst_bdv [] t = t : term - | inst_bdv (instl: (term*term) list) t = - let fun subst (v as Var((s,_),T)) = - (case explode s of - "b"::"d"::"v"::_ => - if_none (assoc(instl,Free(s,T))) (Free(s,T)) - | _ => v) - | subst (Abs(a,T,body)) = Abs(a, T, subst body) - | subst (f$t') = subst f $ subst t' - | subst t = if_none (assoc(instl,t)) t - in subst t end; - - -(*WN050829 caution: is_atom (str2term"q_0/2 * L * x") = true !!! - use length (vars term) = 1 instead*) -fun is_atom (Const ("Float.Float",_) $ _) = true - | is_atom (Const ("ComplexI.I'_'_",_)) = true - | is_atom (Const ("op *",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t - | is_atom (Const ("op +",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1 - | is_atom (Const ("op +",_) $ t1 $ - (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_))) = - is_atom t1 andalso is_atom t2 - | is_atom (Const _) = true - | is_atom (Free _) = true - | is_atom (Var _) = true - | is_atom _ = false; -(* val t = str2term "q_0/2 * L * x"; - - -*) -(*val t = str2term "Float ((1,2),(0,0))"; -> is_atom t; -val it = true : bool -> val t = str2term "Float ((1,2),(0,0)) * I__"; -> is_atom t; -val it = true : bool -> val t = str2term "Float ((1,2),(0,0)) + Float ((3,4),(0,0)) * I__"; -> is_atom t; -val it = true : bool -> val t = str2term "1 + 2*I__"; -> val Const ("op +",_) $ t1 $ (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_)) = t; -*) - -(*.adaption from Isabelle/src/Pure/term.ML; reports if ALL Free's - have found a substitution (required for evaluating the preconditions - of _incomplete_ models).*) -fun subst_atomic_all [] t = (false, (*TODO may be 'true' for some terms ?*) - t : term) - | subst_atomic_all (instl: (term*term) list) t = - let fun subst (Abs(a,T,body)) = - let val (all, body') = subst body - in (all, Abs(a, T, body')) end - | subst (f$tt) = - let val (all1, f') = subst f - val (all2, tt') = subst tt - in (all1 andalso all2, f' $ tt') end - | subst (t as Free _) = - if is_num t then (true, t) (*numerals cannot be subst*) - else (case assoc(instl,t) of - SOME t' => (true, t') - | NONE => (false, t)) - | subst t = (true, if_none (assoc(instl,t)) t) - in subst t end; - -(*.add two terms with a type given.*) -fun mk_add t1 t2 = - let val T1 = type_of t1 - val T2 = type_of t2 - in if T1 <> T2 then raise TYPE ("mk_add gets ",[T1, T2],[t1,t2]) - else (Const ("op +", [T1, T2] ---> T1) $ t1 $ t2) - end; - diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/Test.thy --- a/src/Tools/isac/Test.thy Wed Aug 25 15:15:01 2010 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -theory Test imports Main begin; - theorem my_thm: " A & B --> B & A"; - proof; - assume " A & B"; - then obtain B and A ..; - then show "B & A" ..; - qed; diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/calcelems.sml --- a/src/Tools/isac/calcelems.sml Wed Aug 25 15:15:01 2010 +0200 +++ b/src/Tools/isac/calcelems.sml Wed Aug 25 16:20:07 2010 +0200 @@ -342,7 +342,7 @@ (*rewrite orders, also stored in 'type met' and type 'and rls' The association list is required for 'rewrite.."rew_ord"..' - WN0509 tests not well-organized: see smltest/IsacKnowledge/termorder.sml*) + WN0509 tests not well-organized: see smltest/Knowledge/termorder.sml*) val rew_ord' = ref ([]:(rew_ord' * (*the key for the association list *) (subst (*the bound variables - they get high order*) diff -r a28b5fc129b7 -r 22235e4dbe5f src/Tools/isac/xmlsrc/mathml.sml --- a/src/Tools/isac/xmlsrc/mathml.sml Wed Aug 25 15:15:01 2010 +0200 +++ b/src/Tools/isac/xmlsrc/mathml.sml Wed Aug 25 16:20:07 2010 +0200 @@ -13,10 +13,10 @@ 'isac.util.parser.FormalizationDigest.decodeEntities' called within Formula#toSMLString in java - ad(1) decode "^^^" ---> "^"; see IsacKnowledge/Atools.thy; + ad(1) decode "^^^" ---> "^"; see Knowledge/Atools.thy; ad(2) decode "<" ---> "<", decode ">" ---> ">" decode "&" ---> "&" - called for term2xml; + see "fun encode" in FE-interface/interface.sml.*) + called for term2xml; + see "fun encode" in Frontend/interface.sml.*) fun decode (str:cterm') = let fun dec [] = [] | dec ("^"::"^"::"^"::cs) = "^"::(dec cs) @@ -35,7 +35,7 @@ val indentation = 2; val i = indentation; -(*WN071016 checked that _all_ FE-interface/interface.sml uses this*) +(*WN071016 checked that _all_ Frontend/interface.sml uses this*) fun term2xml j t = indt (j+i) ^ "\n" ^ indt (j+2*i) ^ " " ^ (decode o term2str) t ^ " \n" ^