From 73c6fc18093d5b789c36390db65291e9a01aa7ba Mon Sep 17 00:00:00 2001 From: Lennart Kramer Date: Mon, 3 Jun 2024 18:43:42 +0200 Subject: [PATCH] add stackmaxima 2024060300 --- README.md | 1 + stack/2024060300/maxima/assessment.mac | 2551 +++++++++++++ stack/2024060300/maxima/assessment.texi | 568 +++ stack/2024060300/maxima/contrib/matchlib.mac | 160 + stack/2024060300/maxima/contrib/prooflib.mac | 444 +++ .../maxima/contrib/prooflib_test.mac | 73 + .../analysis-sequence-sum-diverge.mac | 23 + .../contrib/proofsamples/harmonic-series.mac | 16 + .../maxima/contrib/proofsamples/index.md | 26 + .../contrib/proofsamples/inf-primes.mac | 26 + .../irrational-power-irrational.mac | 17 + .../proofsamples/log-two-three-irrational.mac | 36 + .../contrib/proofsamples/odd-squaredodd.mac | 30 + .../proofsamples/root-two-irrational.mac | 30 + .../contrib/proofsamples/set-equality.mac | 20 + .../contrib/proofsamples/sum-odd-int.mac | 23 + .../2024060300/maxima/contrib/validators.mac | 56 + .../maxima/contrib/validators_test.mac | 49 + .../maxima/contrib/vectorcalculus.mac | 75 + .../maxima/contrib/vectorcalculus_test.mac | 77 + stack/2024060300/maxima/elementary.mac | 195 + stack/2024060300/maxima/errortostring.lisp | 8 + stack/2024060300/maxima/expandfeedback.mac | 122 + stack/2024060300/maxima/experimental.mac | 71 + stack/2024060300/maxima/fboundp.mac | 99 + stack/2024060300/maxima/geometry.mac | 99 + stack/2024060300/maxima/inequalities.mac | 322 ++ stack/2024060300/maxima/intervals.mac | 963 +++++ stack/2024060300/maxima/local.mac | 1 + stack/2024060300/maxima/noun_arith.lisp | 53 + stack/2024060300/maxima/noun_simp.mac | 671 ++++ stack/2024060300/maxima/numericaltest.mac | 464 +++ stack/2024060300/maxima/print-comma.lisp | 68 + stack/2024060300/maxima/proof.mac | 20 + .../maxima/rtest_assessment_simpboth.mac | 392 ++ .../maxima/rtest_assessment_simpfalse.mac | 125 + .../maxima/rtest_assessment_simptrue.mac | 86 + .../2024060300/maxima/rtest_experimental.mac | 0 .../2024060300/maxima/rtest_inequalities.mac | 238 ++ stack/2024060300/maxima/rtest_intervals.mac | 170 + stack/2024060300/maxima/rtest_noun_simp.mac | 208 + stack/2024060300/maxima/s_test_case.lisp | 4 + stack/2024060300/maxima/s_test_case.mac | 70 + stack/2024060300/maxima/sandbox.wxm | 107 + stack/2024060300/maxima/stack44.mac | 12 + stack/2024060300/maxima/stack_logic.lisp | 682 ++++ stack/2024060300/maxima/stackmaxima.mac | 3337 +++++++++++++++++ stack/2024060300/maxima/stackreporting.mac | 27 + stack/2024060300/maxima/stackstrings.mac | 480 +++ stack/2024060300/maxima/stacktex.lisp | 532 +++ stack/2024060300/maxima/stacktex40.lisp | 121 + stack/2024060300/maxima/stackunits.mac | 603 +++ .../maxima/to_poly_solve_extra_5.38.1.lisp | 211 ++ stack/2024060300/maxima/trigrat.lisp | 56 + stack/2024060300/maxima/unittests_load.mac | 38 + stack/2024060300/maxima/utils.mac | 320 ++ stack/2024060300/maxima/validator.mac | 234 ++ stack/2024060300/maximalocal.mac.template | 41 + versions | 1 + 59 files changed, 15552 insertions(+) create mode 100644 stack/2024060300/maxima/assessment.mac create mode 100644 stack/2024060300/maxima/assessment.texi create mode 100644 stack/2024060300/maxima/contrib/matchlib.mac create mode 100644 stack/2024060300/maxima/contrib/prooflib.mac create mode 100644 stack/2024060300/maxima/contrib/prooflib_test.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/analysis-sequence-sum-diverge.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/harmonic-series.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/index.md create mode 100644 stack/2024060300/maxima/contrib/proofsamples/inf-primes.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/irrational-power-irrational.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/log-two-three-irrational.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/odd-squaredodd.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/root-two-irrational.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/set-equality.mac create mode 100644 stack/2024060300/maxima/contrib/proofsamples/sum-odd-int.mac create mode 100644 stack/2024060300/maxima/contrib/validators.mac create mode 100644 stack/2024060300/maxima/contrib/validators_test.mac create mode 100644 stack/2024060300/maxima/contrib/vectorcalculus.mac create mode 100644 stack/2024060300/maxima/contrib/vectorcalculus_test.mac create mode 100644 stack/2024060300/maxima/elementary.mac create mode 100644 stack/2024060300/maxima/errortostring.lisp create mode 100644 stack/2024060300/maxima/expandfeedback.mac create mode 100644 stack/2024060300/maxima/experimental.mac create mode 100644 stack/2024060300/maxima/fboundp.mac create mode 100644 stack/2024060300/maxima/geometry.mac create mode 100644 stack/2024060300/maxima/inequalities.mac create mode 100644 stack/2024060300/maxima/intervals.mac create mode 100644 stack/2024060300/maxima/local.mac create mode 100644 stack/2024060300/maxima/noun_arith.lisp create mode 100644 stack/2024060300/maxima/noun_simp.mac create mode 100644 stack/2024060300/maxima/numericaltest.mac create mode 100644 stack/2024060300/maxima/print-comma.lisp create mode 100644 stack/2024060300/maxima/proof.mac create mode 100644 stack/2024060300/maxima/rtest_assessment_simpboth.mac create mode 100644 stack/2024060300/maxima/rtest_assessment_simpfalse.mac create mode 100644 stack/2024060300/maxima/rtest_assessment_simptrue.mac create mode 100644 stack/2024060300/maxima/rtest_experimental.mac create mode 100644 stack/2024060300/maxima/rtest_inequalities.mac create mode 100644 stack/2024060300/maxima/rtest_intervals.mac create mode 100644 stack/2024060300/maxima/rtest_noun_simp.mac create mode 100644 stack/2024060300/maxima/s_test_case.lisp create mode 100644 stack/2024060300/maxima/s_test_case.mac create mode 100644 stack/2024060300/maxima/sandbox.wxm create mode 100644 stack/2024060300/maxima/stack44.mac create mode 100644 stack/2024060300/maxima/stack_logic.lisp create mode 100644 stack/2024060300/maxima/stackmaxima.mac create mode 100644 stack/2024060300/maxima/stackreporting.mac create mode 100644 stack/2024060300/maxima/stackstrings.mac create mode 100644 stack/2024060300/maxima/stacktex.lisp create mode 100644 stack/2024060300/maxima/stacktex40.lisp create mode 100644 stack/2024060300/maxima/stackunits.mac create mode 100644 stack/2024060300/maxima/to_poly_solve_extra_5.38.1.lisp create mode 100644 stack/2024060300/maxima/trigrat.lisp create mode 100644 stack/2024060300/maxima/unittests_load.mac create mode 100644 stack/2024060300/maxima/utils.mac create mode 100644 stack/2024060300/maxima/validator.mac create mode 100644 stack/2024060300/maximalocal.mac.template diff --git a/README.md b/README.md index da94dd7..d54aed8 100644 --- a/README.md +++ b/README.md @@ -90,6 +90,7 @@ What Stackmaxima version do I need? | - | `4.4.6` | 2023102700 | 5.44.0 | | `7.5`, `8.5` | `4.5.0` | 2023121100 | 5.44.0 | | - | `4.5.0-hf2` | 2024012900 | 5.44.0 | +| - | `4.6.0` | 2024060300 | 5.44.0 | Environment Variables diff --git a/stack/2024060300/maxima/assessment.mac b/stack/2024060300/maxima/assessment.mac new file mode 100644 index 0000000..e102cdf --- /dev/null +++ b/stack/2024060300/maxima/assessment.mac @@ -0,0 +1,2551 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2018 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/****************************************************************/ +/* An assessment package for Maxima */ +/* */ +/* Chris Sangwin, */ +/* V1.0 May 2018 */ +/* */ +/****************************************************************/ + +MAXIMA_VERSION:map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp))$ +MAXIMA_VERSION_NUM:float(MAXIMA_VERSION[2]+(if is(length(MAXIMA_VERSION)>2) + then (if is(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 else 0) else 0))$ + +/* ********************************** */ +/* Load contributed packages */ +/* ********************************** */ + +if not(?functionp('poly_reduced_grobner)) then load("grobner"); + +/* Package dependency: makes use of the %and and %or functions from to_poly_solver. + Taken from version 5.38.1 to be definite, and for back compatability. */ +load("to_poly_solve_extra_5.38.1.lisp"); +load("opsubst"); + +if not(?functionp('rempart)) then load(functs); + +/* ********************************** */ +/* Parts of expressions */ +/* ********************************** */ + +/* op(ex) is unsafe on atoms: this is a fix. */ +/* This function always returns a string. */ +safe_op(ex) := block([st], + /* Subtle changes in mapatom, in Maxima 5.42.2, with simp:false. */ + if atom(ex) then return(""), + if op(ex) = "-" then return("-"), + if op(ex) = "/" then return("/"), + if op(ex) = "integrate" then return("int"), + /* Catch a subscript. */ + if mapatom(ex) then return(""), + if stringp(op(ex)) then return(op(ex)), + st:string(op(ex)), + /* %and operators are displayed as "?%and" on some systems and "%and" on others.*/ + if ?subseq(st, 0, 1) = "?" then + st:?subseq(st, 1, ev(?length(st), simp)), + return(st) +)$ + +get_safe_ops(ex) := setify(flatten(get_safe_ops_helper(ex)))$ +get_safe_ops_helper(ex) := if mapatom(ex) then [] else append([safe_op(ex)], maplist(get_safe_ops_helper, args(ex)))$ + +/* This function takes an expression ex and returns a list of coefficients of v. */ +coeff_list(ex, v) := block([deg, kloop, cl], + cl:[], + ex:ev(expand(ex), simp), + deg:hipow(ex, v), + ev(for kloop:0 thru deg do + cl:append(cl, [coeff(ex, v, kloop)]), simp), + cl +)$ + +/* This function takes an expression ex and returns a list of nonzero coefficients of v. */ +coeff_list_nz(ex, v) := block([deg, kloop, cl], + cl:[], + ex:ev(expand(ex), simp), + deg:hipow(ex, v), + ev(for kloop:0 thru deg do + if coeff(ex, v, kloop)#0 then cl:append(cl, [[kloop, coeff(ex, v, kloop)]]), simp), + cl +)$ + +/* Equate coefficients of two polynomials. */ +poly_equate_coeffs(p1,p2,v) := block([deg,kloop,cl], + /* Based on the code for coeff_list, but we need to run over the end. */ + cl:[], + p1:ev(expand(p1),simp), + p2:ev(expand(p2),simp), + deg:max(hipow(p1,v), hipow(p1,v)), + ev(for kloop:0 thru deg do + cl:append(cl,[coeff(p1,v,kloop)=coeff(p2,v,kloop)]),simp), + cl +); + +/* Can we equate coefficients, and if so in what variable? */ +poly_equate_coeffsp(p1, p2) := block([lov1, lov2, poly1, andex1, andex2, numvardiff, vardiff, ansnote], + lov1:setify(listofvars(p1)), + lov2:setify(listofvars(p2)), + numvardiff:ev(length(lov1)-length(lov2), simp), + /* The difference in the number of variables has to be exactly one. */ + if not(is(ev(abs(numvardiff=1),simp))) then return(false), + if is(length(lov1)-length(lov2)=1) then block( + poly1:lhs(p1)-rhs(p1), + andex2:p2, + vardiff:first(args(setdifference(lov1,lov2))), + ansnote:EQUATECOEFFLOSS(vardiff) + ) else ( + poly1:lhs(p2)-rhs(p2), + andex2:p1, + vardiff:first(args(setdifference(lov2,lov1))), + ansnote:EQUATECOEFFGAIN(vardiff) + ), + /* In the call below we only check it is a polynomial in its first variable. */ + if not(polynomialp(poly1, [vardiff],'lambda([ex], true), 'integerp) and safe_op(andex2)="nounand") then return(false), + /* We can only equate coefficients of polynomials where the list of */ + andex1:apply("nounand", args(poly_equate_coeffs(lhs(poly1)-rhs(poly1), 0, vardiff))), + + if debug then print([poly1, andex1, andex2, vardiff]), + + ret:ATAlgEquiv(andex1, andex2), + if debug then print(["poly_equate_coeffsp: ", ret]), + if first(ret) then return(ansnote) else return(false) +)$ + +/* Return the set of operations which occur in the expression. */ +/* Note, this function varies depending on the value of simp! */ +/* E.g. x+x-> 2*x, so is this a product of sum? */ +get_ops(ex):= setify(flatten(get_ops_helper(ex)))$ +get_ops_helper(ex):=if mapatom(ex) then [] else append([op(ex)],maplist(get_ops_helper,args(ex)))$ + +/* Predicate to test if an operator is used in an expression. */ +op_usedp(ex, opused) := block( + if atom(ex) then return(false), + if op(ex)=opused then return(true), + apply("or", maplist(lambda([ex2], op_usedp(ex2, opused)), args(ex))) +)$ + +/* Count the occurances of v in ex. + v can be a string (for safe_op) or atom. +*/ +count_occurances(ex, v):=block([isop], + if ex=v then return(1), + if atom(ex) then return(0), + isop:0, + if safe_op(ex)=v then isop:1, + isop+apply("+", map(lambda([ex2], count_occurances(ex2, v)), args(ex))) +)$ +/* Recurse over a whole expression tree to see if the predicate is satisfied anywhere. */ +recurse_predp(ex, pr):= block( + if mapatom(ex) then return(pr(ex)), + pr(ex) or apply("or", map(lambda([ex2], recurse_predp(ex2, pr)), args(ex))) +); + +/* ********************************************** */ +/* Functions for selecting parts of an expression */ +/* ********************************************** */ + +/* This function selects, and displays, parts of an expression for which the predicate is true. */ +select(p1, ex) := block( + if p1(ex) then return(disp_select(ex)), + if atom(ex) then return(ex), + apply(op(ex), map(lambda([ex2], select(p1, ex2)), args(ex))) +)$ + +/* This function applys the function f1 to parts already selected by the function select. */ +select_apply([ex1]) := block([f1, ex, s1], + f1:first(ex1), + ex:second(ex1), + s1:true, + if ev(is(length(ex1)>2), simp) then s1:third(ex1), + if atom(ex) then return(ex), + if safe_op(ex)="disp_select" then if s1 then return(f1(first(args(ex)))) else return(f1(ex)), + apply(op(ex), map(lambda([ex2], select_apply(f1, ex2, s1)), args(ex))) +)$ + +/* ********************************** */ +/* General list and utility functions */ +/* ********************************** */ + +/* True if and only if ex is in the list l. */ +element_listp(ex, l) := any_listp(lambda([ex2], is(ex2=ex)), l)$ + +/* all_listp(p,l) true if all elements of l satisfy p. */ +all_listp(p, l) := if listp(l) then apply("and", maplist(p, l)) else error("all_listp expects its argument to be a list.")$ + +/* any_listp(p,l) true if all elements of l satisfy p. */ +any_listp(p, l) := if listp(l) then apply("or", maplist(p, l)) else error("any_listp expects its argument to be a list.")$ + +/* Returns true iff a and b are lists (not necessarily same length) with one or more common elements, false o/w. */ +listsoverlap(a, b) := not(emptyp(intersection(setify(a), setify(b))))$ + +/* Returns true iff a and b are lists (not necessarily same length) and contain the common element v */ +listscontain(a, b, v) := elementp(v, intersection(setify(a), setify(b)))$ + +/* Removes the first occurance of ex from the list l. */ +removeonce(ex, l) := block( + if listp(l)#true or emptyp(l) then return([]), + if first(l)=ex then return(rest(l)), + append([first(l)], removeonce(ex,rest(l))) +)$ + +/* All the elements of l1, which do not occur in l2. Removes all occurances from l1, not one at a time. */ +listdifference(l1, l2) := block( + if emptyp(l1) or emptyp(l2) then return(l1), + listdifference(sublist(l1, lambda([ex], not(ev(is(ex=first(l2)), simp)))), rest(l2)) +); + +/* Remove any common elements from [l1,l2], with duplication. */ +list_cancel(ex) := block([l1, l2, l3], + l1:first(ex), + l2:second(ex), + if not(listp(l1)) or not(listp(l2)) then error("Arguments of list_cancel must be lists."), + if emptyp(l1) then return([l1, l2]), + if emptyp(l2) then return([l1, l2]), + if element_listp(first(l2), l1) then return(list_cancel([removeonce(first(l2), l1), rest(l2)])), + l3:list_cancel([l1, rest(l2)]), + return([first(l3),append([first(l2)], second((l3)))]) +)$ + +/* This function applies the binary function zf to two lists a and b returning a list +[ zf(a[1],b[1]), zf(a[2],b[2]), ... ] zip_with quietly gives up when one of the list runs out of elements. + Actually, we can achieve some of this with map(zf, a, b) but this does not give up quietly + if the arguments are different lengths. +*/ +zip_with(zf, a, b) := block( + if not(listp(a)) then return(false), + if not(listp(b)) then return(false), + if emptyp(a) then return([]), + if emptyp(b) then return([]), + cons(zf(first(a), first(b)), zip_with(zf, rest(a), rest(b))) +)$ + +/* This function makes a substitution of all variables for their lower case equivalents. + Useful when wanting to do a specific case sensitivity + check, e.g. that X^2=1 is x^2=1, without using subst_equiv. + + Note that exdowncase(X-x)=0, of course! + And exdowncase(1/(R-r)) could create a division by zero. +*/ +exdowncase(ex) := block([lv, ex2], + lv:listofvars(ex), + lv:map(lambda([v], v=parse_string(sdowncase(string(v)))),lv), + ex2:errcatch(subst(lv,ex)), + if emptyp(ex2) then return(ex), + return(first(ex2)) +)$ + +/* Maxima does not have its own degree command! */ +/* See notes on hipow. */ +degree(ex,v) := ev(hipow(expand(ex), v), simp); + +/* is(ex) does not work when simp:false.*/ +is_simp(ex) := ev(is(ex), simp)$ + +/* ********************************** */ +/* Control the display of lists */ +/* ********************************** */ + +/* An expression sequence is displayed without square brackets. */ +texsequence (e) := simplode(maplist(tex1,args(e)), ", ")$ +texput(sequence, texsequence)$ + +/* Convenience functions creating sequences. */ +sequenceify(ex):= apply(sequence, args(ex))$ +sequencep(ex):= if safe_op(ex)="sequence" then true else false$ + +/* An "ntuple" is displayed with round brackets. */ +texntuple(e) := concat("\\left(", simplode(maplist(tex1,args(e)), ", "), "\\right)")$ +texput(ntuple, texntuple)$ + +ntupleify(ex):= apply(ntuple, args(ex))$ +ntuplep(ex):= if safe_op(ex)="ntuple" then true else false$ + +/* An ellipsis */ +texput(dotdotdot, "\\ldots")$ + +/* Control TeX parens for display only. */ +/* E.g. {@lrparens(".", x^2+3, "\\}")@} */ +tex_lrparens(ex):=sconcat("\\left", first(args(ex)), tex1(second(args(ex))), "\\right", third(args(ex))); +texput(lrparens, tex_lrparens); + +/* ********************************** */ +/* Type predicates */ +/* ********************************** */ + +/* It is very useful to know if we have a "variable". */ +variablep(ex) := atom(ex) and not(real_numberp(ex)) and not(ex=%i) and not(stringp(ex))$ + +/* Determines if we are using an equation. */ +equationp(ex) := block( + if atom(ex) then return(false), + if "="= op(ex) then return(true), + return(false) +)$ + +/* Determines if we are using a function. */ +functionp(ex) := block( + if atom(ex) then return(false), + if ":="= op(ex) then return(true), + return(false) +)$ + +/* Determines if we are using an inequality. */ +inequalityp(ex) := block( + if atom(ex) then return(false), + if ">" = op(ex) or "<" = op(ex) or ">=" = op(ex) or "<=" = op(ex) then return(true), + if "and" = op(ex) or "or" = op(ex) or "not" then return(true), + return(false) +)$ + +/* Determines if ex looks like a basic mathematical expression. */ +expressionp(ex) := block( + if matrixp(ex) or listp(ex) or equationp(ex) or inequalityp(ex) or safe_setp(ex) or functionp(ex) or logicp(ex) or stringp(ex) then + return(false), + return(true) +); + +/* Checks that an expression is a polynomial. */ +polynomialpsimp(ex):= block([v], + v:listofvars(ex), + if is(v=[]) then return(simp_numberp(ex)), + polynomialp(ex, v) +)$ + +calculusp(ex) := block( + if atom(ex) then return(false), + if "diff" = op(ex) or "noundiff" = op(ex) or "int" = op(ex) or "nounint" = op(ex) then return(true), + return(false) +)$ + + +/* This is to fix a bug in Maxima 5.38.1. */ +safe_setp(ex) := setp(ex) or safe_op(ex) = "{"$ + +/* ********************************** */ +/* Logarithms and nth roots */ +/* ********************************** */ +alias(ln, log); + +/* Legacy reasons */ +alias(lg, logbase); + +lgtex(ex) := block([n, b], + b:10, + if length(args(ex)) = 1 then n:first(args(ex)), + if length(args(ex)) = 2 then (n:first(args(ex)), b:second(args(ex))), + oldsimp:simp, + return(concat("\\log_{", stack_disp_strip_dollars(tex(b, false)), "}\\left(", stack_disp_strip_dollars(tex(n, false)), "\\right)")) +)$ +texput(lg, lgtex); + +/* Use of radcan to give canonical form. */ +logbasesimp([ex]) := block( + if length(ex) = 1 then return(radcan(log(first(ex))/log(10))), + if length(ex) = 2 then return(radcan(log(first(ex))/log(second(ex)))), + error("STACK function 'lg' must have one or two arguments only.") +)$ + +/* Add in a flexible "nth" roots function. */ +root([ex]) := block( + if length(ex) > 2 then error("root: must have only two arguments"), + if length(ex) = 1 then return(sqrt(first(ex))), + if length(ex) = 2 then return(first(ex)^(1/second(ex))) +)$ + +/* Denominators of fractions should not contain sqrt, root, %i or fractional powers. */ +rational_fail(ex) := block( + if is(ex=%i) then return([%i]), + /* Other atoms are fine. */ + if atom(ex) then return([]), + /* Look for forbidden operators. */ + if safe_op(ex)="root" then return([ex]), + if safe_op(ex)="sqrt" then return([ex]), + if safe_op(ex)="^" and rational_numberp(second(args(ex))) then return([ex]), + maplist(rational_fail, args(ex)) +)$ + +/* This function picks out any rationals in the expression. */ +find_rationals(ex) := block( + if atom(ex) then return([]), + if safe_op(ex)="/" then return(ex), + maplist(find_rationals, args(ex)) +)$ + +/* Toplevel function. + This returns "true" if the denominators of expressionss are free of sqrt, root, %i or fractional powers. + It returns a list of offending terms otherwise. +*/ +rationalized(ex):= block( + ex:find_rationals(ex), + if not(listp(ex)) then ex:[ex], + ex:maplist(denom, find_rationals(ex)), + ex:flatten(maplist(rational_fail, ex)), + if emptyp(ex) then return(true), + return(ex) +)$ + +/* ********************************** */ +/* Numerical operations */ +/* ********************************** */ + +/* numberp() does not "work" when simp:false, since unary minus is an unevaluated function... */ +simp_numberp(ex) := block( + if numberp(ex) then return(true), + if atom(ex) then return(false), + if op(ex)="-" and numberp(first(args(ex))) then return(true), + false +)$ + +simp_floatnump(ex) := block( + if floatnump(ex) then return(true), + if atom(ex) then return(false), + if op(ex)="-" and floatnump(first(args(ex))) then return(true), + false +)$ + +simp_integerp(ex) := block( + if integerp(ex) then return(true), + if atom(ex) then return(false), + if op(ex)="-" and integerp(first(args(ex))) then return(true), + false +)$ + +/* Do we have a rational number? */ +rational_numberp(ex) := block( + if safe_op(ex)="-" then return(rational_numberp(first(ex))), + if safe_op(ex)="/" and simp_integerp(num(ex)) and simp_integerp(denom(ex)) then return(true), + return(false) +)$ + +/* Do we have a real number? */ +/* Code taken from Stack_Test */ +real_numberp(ex):= block([keepfloat, trigexpand, logexpand], + trigexpand:true, + logexpand:super, + keepfloat:true, + /* Using full ratsimp here makes this function unacceptably slow. */ + ex:errcatch(ev(ex, lg=logbasesimp, simp)), + if ex=[] then return(false), + ex:ev(float(ex[1]),simp), + if listofvars(ex)#[] then return(false), + if floatnump(ex) then return(true) else return(false) +)$ + +/* Do we have a complex number? */ +simp_complex_number_p(ex):= block([keepfloat, trigexpand, logexpand], + trigexpand:true, + logexpand:super, + keepfloat:true, + /* Using full ratsimp here makes this function unacceptably slow. */ + ex:errcatch(ev(ex, lg=logbasesimp, displaydp=lambda([ex2,ex3],ex2), displaysci=lambda([ex2,ex3],ex2), simp)), + if ex=[] then return(false), + ex:ev(float(ex[1]),simp), + if listofvars(ex)#[] then return(false), + if floatnump(ex) then return(true), + if complex_number_p(ex) then return(true) else return(false) +)$ + +/* Do we have a real number, inf or -inf? */ +extended_real_numberp(ex) := block( + if (ex=inf or ex=-inf or ex=minf or ex=-minf) then return(true), + return(real_numberp(ex)) +)$ + +/* Decide if we have a purely imaginary number. */ +imag_numberp(ex) := block( + ev(is(equal(ex, %i*imagpart(ex))), simp) +)$ + +/* Decide if a number is written in complex exponential form, r*%e^(%i*theta). + Needs simp:false. */ +complex_exponentialp(ex):=block([ex2], + /* Edge case of a real number! */ + if ev(real_numberp(ex), simp) then return(true), + ex2:ex, + if safe_op(ex)="-" then return(complex_exponentialp(first(args(ex)))), + if safe_op(ex)="*" then + if not(is(real_numberp(first(args(ex))))) then + return(false) + else + ex2:second(args(ex)), + if safe_op(ex)="/" then + if not(is(real_numberp(second(args(ex))))) then + return(false) + else + ex2:first(args(ex)), + /* Case of r=1, which is not written, or stripped off by the above code. */ + if safe_op(ex2)="^" then + if is(equal(first(args(ex2)),%e)) and is(imag_numberp(second(args(ex2)))) then + return(true), + if safe_op(ex2)="exp" and is(imag_numberp(first(args(ex2)))) then return(true), + return(false) +)$ + +polarform_simp(ex) := block([%_r, %_theta, %_pf, simp], + /* We can't return a meaningful value for arg(ex) so we just return 0. */ + if is(ev(ex, simp)=0) then return(0), + /* It is a design choice to return a positive real number, rather than r*%e^0, or r*%e^(%i*0). */ + if ev(real_numberp(ex) and ex>0, simp) then return(ex), + simp:false, + %_pf:ev(polarform(ex), simp), + /* Purely imaginary numbers somtimes return just %e^{...} */ + if is(part(%_pf,1)=%e) then return(%_pf), + /* We really do have something in the form r*%e^theta to pick apart. */ + %_pf:args(%_pf), + %_r:first(%_pf), + %_theta:part(second(%_pf),2), + ev(%_r, simp) * %e^(ev(%i*imagpart(%_theta), simp)) +)$ +/* + polarform_simp(1+%i); + polarform_simp(0); + polarform_simp(1); + polarform_simp(-2); + polarform_simp(%i); + polarform_simp(2*%i); + polarform_simp(-%i); + polarform_simp(-2*%i); + polarform_simp(sqrt(3)+%i*sqrt(3)); + polarform_simp(1/sqrt(2)*(-1+%i)); +*/ + + +/* Decides if an expression is precicely of the form a*10^n, where a is an integer, or a float, and n is an integer. */ +scientific_notationp(ex) := block([tn], + if not(safe_op(ex)="*") then return(false), + if not(length(args(ex))=2) then return(false), + tn:first(args(ex)), + if safe_op(tn)="-" then tn:first(args(tn)), + if not(integerp(tn) or floatnump(tn) or safe_op(tn)="displaydp" or safe_op(tn)="displaysci") then return(false), + tn:second(args(ex)), + /* Special edge case: 3*10 = 3*10^1. */ + if tn=10 then return(true), + if not(safe_op(tn)="^") then return(false), + if not(first(args(tn))=10) then return(false), + /* Of course, unary minus bites us here. */ + tn:second(args(tn)), + if safe_op(tn)="-" then tn:first(args(tn)), + if integerp(tn) then return(true), + return(false) +)$ + +/* commonfaclist(l) returns the gcd of a list of numbers. */ +commonfaclist(l) := block([i, a, ret], + if listp(l) then + ret:( a:l[1], + if length(l)>1 then + ev(for i:2 thru length(l) do (a:ev(gcd(a, l[i]), simp)), simp), + return(a)) + else ret:"fail", + return(ret) )$ + +/* Returns a list of factors of ex without multiplicities. */ +factorlist(ex) := block([simp:false, ret:"", ex2], + ex:ev(factor(ex), simp), + if mapatom(ex) then return([ex]), + if safe_op(ex)="-" then ex:first(args(ex)), + if op(ex)#"*" then + ret:[ex] + else + ret:args(ex), + /* Strip off powers. */ + ret:maplist(lambda([ex2], if atom(ex2) then ex2 else if op(ex2)="^" then part(ex2,1) else ex2), ret), + return(ret) +)$ + +/* Is the fraction in its lowest terms? */ +lowesttermsp(ex) := block([simp:false,ex1,ex2,ex3], + if atom(ex) then return(true), + if op(ex)#"/" then return(true), + if safe_op(num(ex))="-" and safe_op(denom(ex))="-" then return(false), + if gcd(num(ex),denom(ex))=1 then return(true) else return(false) +)$ + +/* Create a list with all parts for which numberp(ex)=true, or which appear to be rational numbers. */ +list_expression_numbers(ex) := block([ex2], + if mapatom(ex) then (if numberp(ex) then return([ex]) else return([])) + else ( + if op(ex)="/" and simp_numberp(num(ex)) and simp_numberp(denom(ex)) then return([ex]), + if op(ex)="-" then return(maplist(lambda([ex], if safe_op(ex)="/" then (-num(ex))/denom(ex) else -ex), list_expression_numbers(first(args(ex))))), + ex2:args(ex), + flatten(maplist(list_expression_numbers, ex2))) +)$ + +all_lowest_termsex(ex):= block([simp:false, ex2], + ex2:list_expression_numbers(ex), + all_listp(lowesttermsp,ex2) +)$ + +/* anyfloats(l) returns true if any of the list are floats */ +anyfloat(l) := block([ret:false], + if listp(l)=false then ret:"fail", + ev(l:map('floatnump,l),simp), + ev(for i:1 thru length(l) do (ret:ret or l[i]), simp), + return(ret) )$ + +/* Decides if any floats are in the expression. */ +anyfloatex(ex) := block([partswitch, end, ret, kloop], + ret:false, + ex:ev(ex,simp), + if floatnump(ex) then return(true), + if atom(ex) then return(false), + partswitch:true, + ev(for kloop:1 while part(ex,kloop)#end do + ret:ret or anyfloatex(part(ex,kloop)),simp), + return(ret) +)$ + +/* Apply radcan to things which look like a number. Needed to transform expressions + like "2^(3/2)/sqrt(3)-(2*sqrt(6))/3" to zero, without expanding out brackets in general. */ +radcan_num(ex):= block( + if atom(ex) then return(ex), + /* Something without variables should have radcan applied. */ + if emptyp(listofvars(ex)) then return(radcan(ex)), + apply(op(ex), map(radcan_num, args(ex))) +)$ + +/* Check if - appears in an expression. */ +freeof_mminusp(ex) := block( + if atom(ex) then return(true), + if safe_op(ex)="-" then return(false), + all_listp(freeof_mminusp, args(ex)) +)$ + +/* Fine control over the display of complex numbers. + This general purpose function "does the right thing" with simplification assumed to be true. +*/ +display_complex(ex) := block([exr, exi], + if real_numberp(ex) then return(ex), + exr:ev(realpart(ex), simp), + exi:ev(imagpart(ex), simp), + if is(exr=0) then exr:null, + if is(exi=1) then exi:null, + if ev(is(exi=-1),simp) then exi:-1*null, + disp_complex(exr, exi) + )$ + +texdisp_complex(ex) := block([ps, sxr, exi, simp], + simp:false, + ps:"+", + if is(first(args(ex))=null) then block( + sxr:"", + ps:"" + ) else sxr:tex1(first(args(ex))), + exi:second(args(ex)), + + if real_numberp(exi) then block( + if ev(is(exi < 0), simp) then ps: "", + return(sconcat(sxr, ps, tex1(exi), "\\,", tex1(%i))) + ) else if ev(is(exi=null), simp) then return(sconcat(sxr, ps, tex1(%i))) + else if ev(is(exi=-1*null), simp) then return(sconcat(sxr, "-", tex1(%i))) + else block( + if not(freeof_mminusp(exi)) then block( + ps:"-", + /* TO-DO: more subtle removal of the minus sign?! */ + exi:ev(-1*exi, simp) + ), + sconcat(sxr, ps, tex1(%i), "\\,", tex1(exi)) + ) +)$ +texput(disp_complex, texdisp_complex)$ + +/* Because we have null being used differently in two places we need a remove function. */ +remove_disp_complex(ex1, ex2) := ev(ex1, null=0)+ev(ex2, null=1)*%i$ + +/* This function is a display-level way to ensure brackets get displayed. */ +texdisp_parens(ex) := sconcat("\\left( ", tex1(first(args(ex))), " \\right)")$ +texput(disp_parens, texdisp_parens)$ + +remove_disp_parens(ex) := ev(ex, disp_parens=lambda([ex2], ex2))$ + +/* This function is a display-level way to select part of an expression. */ +texdisp_select(ex) := sconcat("\\color{red}{\\underline{", tex1(first(args(ex))), "}}")$ +texput(disp_select, texdisp_select)$ + +/* A single function to remove display forms. Used by answer tests to "clean" an expression. */ + +remove_disp(ex) := ev(ex, disp_parens=lambda([ex2], ex2), disp_select=lambda([ex2], ex2), disp_complex=remove_disp_complex)$ + + +/* This function is designed for displaying decimal places. It is also useful for currency. */ +/* displaydp(n, dp) is an inert function. The tex function converts this to display. */ +/* n is the number to be displayed */ +/* dp is the number of decimal places */ +/* Note, displaydp does not do any rounding, it is only display. Use significantfigures. */ +/* To print out *values* with trailing decimal places use this function. */ + +displaydptex(ex):=block([ss, n, dp, tx], + [n, dp]:args(ex), + ss:sconcat("~,", string(dp), "f"), + if is(equal(dp,0)) then ss:"~d", + tx:ev(printf(false, ss, ev(float(n))), simp), + if is(stackfltsep = ",") then ( + tx:ssubst("\\ ", ",", tx), + tx:ssubst("{,}", ".", tx) + ), + tx +); +texput(displaydp, displaydptex); + +make_displaydpvalue(ex):= block([n,d], + if atom(ex) then return(ex), + if taylorp(ex) or functionp(ex) or freeof(displaydp, ex) then return(ex), + if arrayp(ex) then return(arraymake(op(ex), maplist(make_displaydpvalue, args(ex)))), + if not(is(safe_op(ex)="displaydp")) then return(apply(op(ex), maplist(make_displaydpvalue, args(ex)))), + if not(length(args(ex))=2) then error("displaydp must have exactly 2 arguments"), + n:ev(float(first(args(ex))), simp), + d:second(args(ex)), + if not(floatnump(n) and integerp(d)) then return(ex), + if is(equal(d,0)) then return(ev(ratsimp(floor(n)), simp)), + return(apply(dispdpvalue, [n, d])) +); + +remove_displaydp(ex):= block( + if atom(ex) then return(ex), + if arrayp(ex) then return(arraymake(op(ex), maplist(make_displaydpvalue, args(ex)))), + if not(is(safe_op(ex)="displaydp")) then return(apply(op(ex), maplist(remove_displaydp, args(ex)))), + return(first(args(ex))) +); + +/* Remove all forms of inert wrappers of numbers. */ +remove_numerical_inert(ex) := block( + if atom(ex) then return(ex), + if safe_op(ex) = "displaysci" then return(first(args(ex))*10^third(args(ex))), + if safe_op(ex) = "displaysf" then return(first(args(ex))), + if not(freeof(displaydp, ex)) then return(remove_displaydp(ex)), + return(ex) +)$ + +/* Write the number ex in n decimal places */ +decimalplacesfun(ex, n, dispdps) := block([ex2], + ex2:ev(float(round(10^n*float(ex))/(10^n)), lg=logbasesimp, simp), + if dispdps then ex2:displaydp(ex2, n), + return(ex2) + )$ +decimalplaces(ex, n) := decimalplacesfun(ex, n, false)$ +dispdp(ex, n) := block( + if not(real_numberp(ex)) then error("dispdp requires a real number argument."), + if not(integerp(n)) then error("dispdp cannot create a non-integer number of decimal places."), + decimalplacesfun(ex, n, true) +)$ + +/* Write numbers in significant figures */ +/* Matti Pauna, Sun, 23 Oct 2011 */ +sigfigsfun(x, n, dispsigfigs) := block([fpprec:128, fpprintprec:16, simp:true, ex, ex1, ex2, dps], + if listp(x) then return(maplist(lambda([ex], sigfigsfun(ex, n, dispsigfigs)), x)), + if not(real_numberp(x)) then error("sigfigsfun(x,n,d) requires a real number, or a list of real numbers, as a first argument. Received: ", string(x)), + if not(integerp(n)) then error("sigfigsfun(x,n,d) requires an integer as a second argument. Received: ", string(n)), + if not(is(dispsigfigs=true) or is(dispsigfigs=false)) then error("sigfigsfun(x,n,d) requires a boolean as the third argument."), + if (is(x = 0) or is(x = 0.0)) then + if (is(n <= 1)) then return(0) + else if dispsigfigs then return(displaydp(0, n-1)) + else return(0), + sign_of_x:signum(x), + /* Evaluate logarithms to an arbitrary base. */ + x:ev(bfloat(x), lg=logbasesimp, simp), + /* Check again for a zero. E.g. cases like cos(0.5*pi). */ + if (is(x = 0) or is(x = 0.0)) then + if (is(n <= 1)) then return(0) + else if dispsigfigs then return(displaydp(0, n-1)) + else return(0), + /* Evaluate and round. */ + ex:ev(bfloat(log(abs(x))/log(10)), simp), + ex:ev(floor(float(ex)), simp), + /* Modification to round 0.5 up to 1, not down as in Maxima's round command. */ + ex1:float(abs(x)/10^(ex-n+1)), + if ex1-floor(ex1) = 0.5 then + ex2:floor(ex1)+1 + else + ex2:round(ex1), + ex2:ev(bfloat(signum(x)*ex2*10^(ex-n+1)), simp), + ex2:ev(float(ex2), simp), + /* Calculate the number of decimal places again, after rounding. */ + ex:ev(bfloat(log(abs(ex2))/log(10)), simp), + ex:ev(floor(float(ex)), simp), + if is(debug) then print([ex2, ex, n]), + if is(floor(ex2) = ratsimp(ex2)) then ex2:ratsimp(ex2), + if dispsigfigs and is((ex+1-n) < 0) then ex2:displaydp(ex2, n-1-ex), + return(ex2) +)$ + +significantfigures(x, n) := sigfigsfun(x, n, false); +dispsf(x, n) := sigfigsfun(x, n, true); + +/* + scientific_notation(x,n) + Evaluate x as a float (with full simplification), and display this in scientific notation + e*10^k + displaying the results to n significant figures. + + If x is not a real number, then return x without a warning. +*/ +scientific_notation([a]) := block([oldsimp, x, ex, ex2, ex3, exn], + oldsimp:simp, + simp:false, + if ev(is(length(a)=1), simp) then (x:first(a), exn:false) + else if ev(is(length(a)=2), simp) then (x:first(a), exn:second(a)) + else error("scientific_notation takes only one or two arguments"), + x:ev(float(x), lg=logbasesimp, simp), + if real_numberp(x) then ( + ex:ev(floor(float(log(abs(x))/log(10))), simp), + ex2:ev(float(x/10^ex), simp), + + /* Edge case of 10. */ + if ev(is(abs(abs(ex2)-10.0)<1e-10), simp) then block( + if ev(sign(x)=pos) then ex2:1.0 else ex2:-1.0, + ex:ev(ex+1, simp) + ), + + ex3:ex2*10^ex, + /* The use of significantfigures here means we don't use banker's rounding but round up. */ + if not(is(exn=false)) then ex3:displaysci(significantfigures(ex2, exn+1), exn, ex), + simp:oldsimp, + return(ex3) + ), + simp:oldsimp, + return(first(a)) +)$ + +/* displysci is an inert internal function of three arguments. */ +displayscitex(ex):=block([ss, n, dp, tx], + [n, dp, expo]:args(ex), + ss:sconcat("~,", string(dp), "f \\times 10^{~a}"), + if is(equal(dp, 0)) then ss:"~d \\times 10^{~a}", + tx:ev(printf(false, ss, ev(float(n)), expo), simp), + if is(stackfltsep = ",") then ( + tx:ssubst("\\ ", ",", tx), + tx:ssubst("{,}", ".", tx) + ), + tx +)$ + +displayscitexE(ex):=block([ss, n, dp, tx], + [n, dp, expo]:args(ex), + ss:sconcat("~,", string(dp), "fE{~a}"), + if is(equal(dp, 0)) then ss:"~dE{~a}", + tx:ev(printf(false, ss, ev(float(n)), expo), simp), + if is(stackfltsep = ",") then ( + tx:ssubst("\\ ", ",", tx), + tx:ssubst("{,}", ".", tx) + ), + tx +)$ + +texput_scientificnotation(ex) := block( + if is(ex="*10") then texput(displaysci, displayscitex), + if is(ex="E") then texput(displaysci, displayscitexE) +)$ + +make_displayscivalue(ex):= block([n, d, expo, ss], + if atom(ex) then return(ex), + if taylorp(ex) or functionp(ex) or freeof(displaysci, ex) then return(ex), + if arrayp(ex) then return(arraymake(op(ex), maplist(make_displayscivalue, args(ex)))), + if not(is(safe_op(ex)="displaysci")) then return(apply(op(ex), maplist(make_displayscivalue, args(ex)))), + if not(length(args(ex))=3) then error("displaysci must have exactly 3 arguments"), + [n, dp, expo]:args(ex), + ss:sconcat("!! ~,", string(dp), "fE~a !!"), + if is(equal(dp, 0)) then ss:"!! ~dE~a !!", + ss:ev(printf(false, ss, ev(float(n)), expo), simp), + return(ss) +)$ + +/* ********************************** */ +/* Some notes on numerical rounding */ +/* ********************************** */ + +/* CJS, Oct 2017. + + To illustrate the problems of numerical rounding with binary floats, see the following examples. + printf(false,"~,0f",14.5); + printf(false,"~,1f",1.45); + printf(false,"~,2f",0.145); + printf(false,"~,3f",0.0145); + printf(false,"~,4f",0.00145); + printf(false,"~,5f",0.000145); + printf(false,"~,6f",0.0000145); + printf(false,"~,7f",0.00000145); + printf(false,"~,8f",0.000000145); + + We might reasonably expect all these to have the last digit as "5", however many of them have "4". + This is not caused by bankers' rounding (which round does). + This is caused by internal rounding. To demonstrate this: + p:0.145; + ex1:(p*100)-floor(p*100); + Then ask is "ex1=0.5"? Actually + ex1-0.5; + returns -1.776356839*10^-15 which shows that (p*100)-floor(p*100)<0.5. This is due to rounding. + Both the internal printf, and our attempts in sigfigsfun(...) to write our own function will suffer from + this kind of problem. +*/ + +/* ********************************** */ +/* Modular arithmetic */ +/* ********************************** */ + +/* Apply modular arithmetic to parts of a larger expression. + Note Maxima's polymod function only works for polynomials. +*/ +recursemod(ex, n) := block( + if numberp(ex) then return(mod(ex, n)), + if atom(ex) then return(ex), + apply(op(ex), map(lambda([ex2], recursemod(ex2, n)), args(ex))) +)$ + +/* ********************************** */ +/* Binomial functions */ +/* ********************************** */ + +binomial_remove(_a, _b):=block( + if listp(_b) then return(_a!/(apply("*", map("!",ev(sort(_b),simp))))), + _a!/(_b!*(_a-_b)!) +)$ + +binomialtex(ex) := block([al], + al:args(ex), + if is(listp(second(al))) then al[2]:apply(sequence,al[2]), + al:maplist(tex1, al), + sconcat("{{", al[1], "}\\choose{", al[2], "}}") + ); +texput(binomial, binomialtex); + +/* ********************************** */ +/* Equivalence */ +/* ********************************** */ + +/* A general all purpose function on **expressions**. + Takes two objects and returns true if they are equal, and false otherwise + This is a "bash as hard as possible" function + + 26/09/12. Avoid fullratsimp after exponentialize. This results in a non-terminating process. + 24/11/13. Avoid fullratsimp. This expands out exprsssions such as (x+a)^6000, which results in an overflow. + 04/01/19. Avoid trigexpand too soon, i.e. before trying to factor. + 24/02/20. Using a lambda expression is causing an infinite loop. Use a named function: algebraic_equivalence_zero. +*/ + +algebraic_equivalence_zero(ex) := algebraic_equivalence(ex, 0)$ + +algebraic_equivalence(SA, SB) := + block([keepfloat, trigexpand, logexpand, sumsplitfact, ex, vi], + + if SA=SB then return(true), + /* Remove +- if we can early. */ + SA:pm_replace(SA), + SB:pm_replace(SB), + + /* Reject obviously different expressions. These can be very time consuming in the tests below. */ + if numerical_not_alg_equiv(SA, SB) then return(false), + trigexpand:false, + logexpand:super, + keepfloat:true, + sumsplitfact:false, + /* In some cases we just go inside the function one level. */ + if (safe_op(SA)=safe_op(SB) and (safe_op(SA)="sqrt" or safe_op(SA)="abs")) then + (SA:first(args(SA)), + SB:first(args(SB))), + /* Remove stackeq. */ + SA:remove_stackeq(SA), + SB:remove_stackeq(SB), + /* Remove scientific units and displaydp from expressions. */ + SA:ev(SA, stackunits="*"), + SB:ev(SB, stackunits="*"), + /* Remove binomial function from expressions in simple cases. */ + SA:subst(binomial=binomial_remove, SA), + SB:subst(binomial=binomial_remove, SB), + SA:remove_numerical_inert(SA), + SB:remove_numerical_inert(SB), + /* Remove logarithms to other bases from expressions. */ + if not(freeof(lg, SA)) then + SA:ev(SA, lg=logbasesimp), + if not(freeof(lg, SB)) then + SB:ev(SB, lg=logbasesimp), + /* Try not to expand out: pure numbers. */ + ex:errcatch(ev(SA-SB, simp)), + if ex=[] then error("algebraic_equivalence: evaluating the difference of two expressions threw an error."), + ex:ex[1], + ex:append([ex], listofvars([ex])), + /* Do our best to collect like terms, and transform numbers to cannonical forms without expanding out. */ + ex:errcatch(ev(apply(collectterms, ex), simp)), + if ex=[] then error("algebraic_equivalence: evaluating collectterms threw an error."), + ex:ex[1], + ex:errcatch(ev(radcan_num(ex), simp)), + if ex=[] then error("algebraic_equivalence: evaluating radcan_num threw an error."), + ex:ex[1], + if numberp(ex) then + if rat(ex)=0 then return(true) + else return (false), + /* Try not to expand out: factoring, but only if without floats. */ + if not(anyfloatex(SA-SB)) then + ex:errcatch(ev(factor(SA-SB), simp)) + else + ex:[ex], + if ex=[] then error("algebraic_equivalence: factoring the difference of two expressions threw an error."), + ex:ex[1], + /* Try to return a negative result without expanding anything! */ + if safe_op(ex)="-" then + ex:first(args(ex)), + if (safe_op(ex)="*" or safe_op(ex)="^") then + if not(any_listp(algebraic_equivalence_zero, args(ex))) then return(false), + keepfloat:false, + ex:errcatch(ratsimp(ex)), + if ex=[] then error("algebraic_equivalence: evaluating the difference of two expressions threw an error."), + ex:ex[1], + if ex=0 then return(true), + /* Next we expand out the difference. */ + ex:errcatch(ev(fullratsimp(SA-SB), simp)), + if ex=[] then error("algebraic_equivalence: evaluating the difference of two expressions threw an error."), + ex:ex[1], + if floatnump(ex) then return(false), + ex:num(ex), /* after a fullratsimp, we have a ratio. We should only need to consider the top */ + trigexpand:true, + ex:trigsimp(ex), + if not(freeof(%i, ex)) then ex:rectform(ex), + ex:exponentialize(ex), + /* ex:trigreduce(ex), CJS, removed 21/1/2010. This was breaking ATSingleFrac! Don't know why. */ + if ratsimp(ex)=0 then return(true), + /* Radcan is slow, and may be causeing timeouts... */ + ex:radcan(ex), + ex:factcomb(ex), + if ratsimp(ex)=0 then return(true), + for vi:1 while ex#sqrtdenest(ex) do ex:sqrtdenest(ex), + if ratsimp(ex)=0 then return(true) else return(false) + )$ + +/* This test establishes if two expressions appear NOT to be equivalent. + It does so by evaluating the expressions numerically. */ +numerical_not_alg_equiv(p1, p2):= block([pvars, pval, lv, sz, pnum, stack_mtell_quiet,listdummyvars,trigexpand], + trigexpand:false, + stack_mtell_quiet:true, + listdummyvars:false, + /* We take the *union* of the two lists of variables, this way we + hedge against comparing (x+a)+(x-a) with 2*x, which are the same. + See issue #748 to see why listofvars([p1,p2]) was changed below. + */ + pvars:unique(append(listofvars(p1),listofvars(p2))), + /* Evaluate as integers to start with and avoid floats. This is safer, and works in many cases.*/ + lv:zip_with("=", pvars, makelist(ev(k+1,simp), k, length(pvars))), + pval:errcatch(subst(lv, p1-p2)), + if is(pval = []) then (print("STACK: ignore previous error. (1)"), return(false)), + pval:errcatch(ev(first(pval), lg=logbasesimp, simp)), + /* We can't remove all these with stack_mtell_quiet, because some are division by zero + which are errors, not warnings. */ + if is(pval = []) then (print("STACK: ignore previous error. (2)"), return(false)), + /* User functions without a function rule cannot be evaluated numerically */ + if recurse_userfunctionp(first(pval)) then return(false), + /* If we have no variables, and not a number, then bail here. */ + if is(emptyp(lv)) and not(numberp(first(pval))) then return(false), + pval:errcatch(ev(is(abs(first(pval)) > 1/10000), simp)), + if is(pval = []) then (print("STACK: ignore previous error. (3)"), return(false)), + if first(pval) then return(true), + /* Evaluate the difference of the expressions at each variable as floats. */ + lv:zip_with("=", pvars, makelist(float((sqrt(2)^k+k*%pi)/4), k, length(pvars))), + /* Maxima 5.43.0 and onwards take a very long time to return "unknown" when we don't have a float in the first place. */ + /* Add a guard cluase for things we can't check numerically. */ + if recurse_predp(p1, numerical_not_expressionp) or recurse_predp(p2, numerical_not_expressionp) then return(false), + /* Now we evaluate the difference of the expressions at each variable. */ + p1:errcatch(subst(lv, p1)), + if is(p1 = []) then (print("STACK: ignore previous error. (4)"), return(false)), + p1:errcatch(ev(float(first(p1)), lg=logbasesimp, numer_pbranch:true, simp)), + if is(p1 = []) then (print("STACK: ignore previous error. (5)"), return(false)), + p2:errcatch(subst(lv, p2)), + if is(p2 = []) then (print("STACK: ignore previous error. (6)"), return(false)), + p2:errcatch(ev(float(first(p2)), lg=logbasesimp, numer_pbranch:true, simp)), + if is(p2 = []) then (print("STACK: ignore previous error. (7)"), return(false)), + /* Make the error here relative, and don't divide by zero. */ + sz:errcatch(ev(abs(float(first(p1)-first(p2))/max(min(abs(first(p1)),abs(first(p2))),1)), simp)), + if is(sz = []) then (print("STACK: ignore previous error. (8)"), return(false)), + pnum:errcatch(floatnump(first(sz))), + if is(pnum = []) then (print("STACK: ignore previous error. (9)"), return(false)), + if not(first(pnum)) then return(false), + if first(sz) > 0.0001 then true else false +)$ + +/* Are there any user-defined functions? */ +recurse_userfunctionp(ex):= block([op1], + if atom(ex) then return(false), + op1:ev(op(ex)), + /* Functions like li use arrays, e.g. li[2](-x). */ + /* While this code does not distinguish between the following, we want to reject + all arrays + p0:li[2](-2*%e^(2*t)); + p1:b[1]; + p2:b[1][2]; + p3:b[1](x); + p4:b[1][2](x); + */ + if arrayp(op1) then while arrayp(op1) do op1:ev(op(op1)), + op1:apply(properties,[op1]), + if emptyp(op1) then return(true), + apply("or", map(recurse_userfunctionp, args(ex))) +)$ + +/* We can try to evaluate matrices here, but anything else is out. */ +numerical_not_expressionp(ex) := block( + /* Noun calculus operations get evaluated, which throws an erros. */ + if listp(ex) or equationp(ex) or inequalityp(ex) or safe_setp(ex) or functionp(ex) or logicp(ex) or stringp(ex) or calculusp(ex) then + return(true), + return(false) +); + +/* This function takes two expressions. + It establishes if there exists a substitution of the variables of ex2 into ex1 which renders + ex1 algebraically equivalent to ex2. + If such a substitution exists the function returns it in a form so that + + ex2 = ev(ex1, subst_equiv(ex1, ex2)) + + If no such permutation exists it returns the empty list []. + If it could not establish this, because there are too many combinations to reasonably consider, + then the function returns false. +*/ +subst_equiv([ex]):=block([ex1, ex2, l1, lv1, lv2, lvi, lvp, lvs, lve, lvpres, il, perm_size, simp], + /* Maintain back-compatibility. */ + ex1: first(ex), + ex2: second(ex), + l1:[], + if length(ex)>2 then l1:third(ex), + if not(listp(l1)) then error("The third argument to subst_equiv must be a list of variables."), + simp:true, + perm_size:4, /* This algorithm is order factorial(perm_size) and so this needs to be small. */ + lv1:setify(listofvars(ex1)), + lv2:setify(listofvars(ex2)), + /* If any of the variables also appear as function names we should get rid of them. + Otherwise we get an infinite loop. */ + lv1:setdifference(lv1, get_ops(ex1)), + lv2:setdifference(lv2, get_ops(ex2)), + if length(lv1)#length(lv2) then return([]), + /* We don't include any variables which the teacher fixes. */ + if not(emptyp(l1)) then ( + l1:setify(l1), + lv1:setdifference(lv1, l1), + lv2:setdifference(lv2, l1) + ), + /* If the lists are too long, try a weaker condition */ + /* We assume the variables which occur in both are correctly assigned. */ + /* Can we find a permutation of those left in each? */ + if length(lv1)>perm_size then ( + lvi:intersection(lv1, lv2), + lv1:setdifference(lv1, lvi), + lv2:setdifference(lv2, lvi) + ), + lv1:listify(lv1), + lv2:listify(lv2), + if length(lv1)>perm_size then return(false), + /* */ + lvp:listify(permutations(lv1)), + /* Create a list of subsitutions */ + lvs:map(lambda([ex], zip_with("=", ex, lv2)), lvp), + lvs:map(sort, lvs), + /* Create list of expressions with which to compare ex1 */ + lve:map(lambda([ex], ev(ex1, ex)), lvs), + lve:map(lambda([ex], ATAlgEquivfun(ex, ex2)), lve), + lve:map(second,lve), + lve:map(lambda([ex], equal(ex, true)), lve), + if apply("or", lve) then (il:sublist_indices(lve, identity), lvs[il[1]]) else [] +)$ + +/* ********************************** */ +/* Simplification control */ +/* ********************************** */ + +/* This function recursively applys associativity to operators listed in oplist. */ +/* It probably only makes sense for oplist to be ["+", "*"] or one of these two. */ +STACK_assoc(ex, oplist) := block( + if atom(ex) then return(ex), + if member(op(ex), oplist) then return(block([ex2], + ex2:flatten(ex), + apply(op(ex2), map(lambda([ex3], STACK_assoc(ex3, oplist)), args(ex2))) + )), + apply(op(ex), map(lambda([ex3], STACK_assoc(ex3, oplist)), args(ex))) +)$ + + +/****************************************************************/ +/* Define noun versions of logical "and" and "or". */ +/****************************************************************/ + +noun_logic_remove(ex) := block([rex], + rex:opsubst("and", "nounand", ex), + rex:opsubst("or", "nounor", rex), + rex:opsubst("not", "nounnot", rex), + return(rex) +)$ + +noun_logic(ex) := block([rex], + rex:subst("nounand", "and", ex), + rex:subst("nounor", "or", rex), + rex:subst("nounnot", "not", rex), + rex +)$ + +nary("nounand", 65)$ +nary("nounor", 61)$ +prefix("nounnot", 70)$ + +declare("nounand", commutative)$ +declare("nounand", lassociative)$ +declare("nounand", rassociative)$ + +declare("nounor", commutative)$ +declare("nounor", lassociative)$ +declare("nounor", rassociative)$ + +logic_edgep(ex) := block( + if is(ex=true) then return(true), + if is(ex=false) then return(true), + if is(ex=all) then return(true), + if is(ex=none) then return(true), + return(false) +)$ + +/* A predicate to decide if we have a logical expression. */ +logicp(ex) := block( + if logic_edgep(ex) then return(true), + if safe_op(ex) = "nounand" then return(true), + if safe_op(ex) = "nounor" then return(true), + if safe_op(ex) = "nounnot" then return(true), + if safe_op(ex) = "and" then return(true), + if safe_op(ex) = "or" then return(true), + if safe_op(ex) = "not" then return(true), + if safe_op(ex) = "nor" then return(true), + if safe_op(ex) = "nand" then return(true), + if safe_op(ex) = "xor" then return(true), + if safe_op(ex) = "xnor" then return(true), + if safe_op(ex) = "implies" then return(true), + if op_usedp(ex, STACKpmOPT) then return(true), + return(false) +)$ + +free_of_logicp(ex) := block([logicops, logiconsts, res, k], + if is(ex=all) or is(ex=none) then return(false), + logicops:["nounand", "nounor", "nounnot", "and", "or", "%and", "%or", "not", "%not", STACKpmOPT, "<", ">", "<=", ">=", "=", "[", "{"], + res:true, + for k: 1 thru length(logicops) do + if ev(not(is(count_op(ex, logicops[k])=0)),simp) then res:false, + return(res) +)$ + +/* A predicate to check if we are free of logic and inequalities. */ +/* I.e. a basic algebraic expression. */ + + +/* DeMorgan's laws: + %not(A %and B) -> %not(A) %or %not(B) + %not(A %or B) -> %not(A) %and %not(B) */ +de_morgan(ex):=block( + if mapatom(ex) then return(ex), + if safe_op(ex)=":=" then return(ex), + if is(safe_op(ex)="%not") and is(safe_op(first(args(ex)))="%and") then + return(apply(?%or, maplist(lambda([ex2], de_morgan(%not(ex2))), args(first(args(ex)))))), + if is(safe_op(ex)="%not") and is(safe_op(first(args(ex)))="%or") then + return(apply(?%and, maplist(lambda([ex2], de_morgan(%not(ex2))), args(first(args(ex)))))), + return(apply(op(ex), maplist(de_morgan, args(ex)))) +)$ + +/* Distribute %and over %or, i.e. A and (B or C) -> (A and B) or (A and C). */ +distrib_and(ex):=block([orlisti, orlist1, orlist2], + if mapatom(ex) then return(ex), + if not(is(safe_op(ex)="%and")) then return(apply(op(ex), maplist(distrib_and, args(ex)))), + orlisti:sublist_indices(args(ex), lambda([ex2], is(safe_op(ex2)="%or"))), + if emptyp(orlisti) then return(apply(op(ex), maplist(distrib_and, args(ex)))), + orlist1:args(ex)[first(orlisti)], + orlist2:rempart(args(ex), first(orlisti)), + distrib_and(apply(?%and, append([apply(?%or, maplist(lambda([ex2], first(orlist2) %and ex2), args(orlist1)))], rest(orlist2)))) +)$ + +/* Normal form for logical expressions. */ +logical_normal(ex):=block( + /* Change the noun logical operators into associative indenpotent ones. */ + ex:abs_replace_eq(ex), + ex:boolean_form(ex), + ex:subst("%and", "nounand", ex), + ex:subst("%or", "nounor", ex), + /* %not is not an infix operator... */ + ex:subst(%not, "not", ex), + ex:subst(%not, "nounnot", ex), + ex:subst("%and", "and", ex), + ex:subst("%or", "or", ex), + ex:de_morgan(ex), + ex:trigsimp(ex), + ex:exponentialize(ex), + ex:ineqprepare(expand(ex)), + ex:noun_solve_logic(ex), + ex:distrib_and(ex), + ex:logical_normal_rem_redundant(ex), + ex:ineqprepare(expand(ex)), + return(ex) +)$ + +logical_normal_rem_redundant(ex):=block( + if mapatom(ex) then return(ex), + if not(is(safe_op(ex)="%and")) then return(apply(op(ex), maplist(logical_normal_rem_redundant, args(ex)))), + ex:ineq_rem_redundant(ex) +)$ + +noun_solve_logic(ex):=block([ex2,ex3,exop,m,fl,p], + if atom(ex) then return(ex), + + /* Solve an equation by factoring and joining each factor with =0 */ + if equationp(ex) then return(noun_solve_logic_equation(ex)), + + /* Solve an equation by factoring and taking even permutations of factors. */ + if inequalityp(ex) then return(inequality_factor_solve(ex)), + + /* Recurse over a logical expression. */ + if logicp(ex) or safe_op(ex) = "%and" or safe_op(ex) = "%or" then return(apply(op(ex), maplist(noun_solve_logic, args(ex)))), + + return(ex) +)$ + +/* Solve the equation using factor, as students would do. */ +noun_solve_logic_equation(ex):=block([factorargs], + factorargs:ev(factor(lhs(ex)-rhs(ex))), + if atom(factorargs) then return(ex), + if safe_op(factorargs)="*" then ex:maplist(lambda([ex2], ex2=0), factorargs) + else return(ex), + if is(length(ex)=1) then first(ex) else apply("nounor", ex) +)$ + +/* To check if two logical expressions are the same, turn them in to polynomials and work there. */ +logic_to_poly(ex) := block( + if atom(ex) then return(ex), + if polynomialp(ex, listofvars(ex)) then return(ex), + + /* Solve an equation by factoring and joining each factor with =0 */ + if equationp(ex) then ex:subst("%or", "nounor", pm_replace(ex)), + if equationp(ex) then return(ineqprepare(ex)), + + if not(logicp(ex) or safe_op(ex) = "%and" or safe_op(ex) = "%or") then return(ex), + + if safe_op(ex) = "%or" or safe_op(ex) = "nounor" or safe_op(ex) = "or" then block([ex2], + ex2:maplist(logic_to_poly, args(ex)), + if (all_listp(equationp, ex2)) then + ex:apply("*", maplist(lhs, ex2))=0 + ), + + return(ex) +)$ + +logic_to_poly_helper(ex, v) := block( + if not(listp(ex)) then return(false), + if ex=[] or length(ex)=1 then return(ex), + logic_to_poly_helper(append([poly_gcd(first(ex), second(ex), v)], rest(rest(ex))), v) +)$ + +/****************************************************************/ +/* Define noun versions of other functions */ +/****************************************************************/ + +/* Maxima does not require more than one argument to diff, e.g. diff(sin(x)) is ok in maxima. + But, for student input we should require the variable! */ +nounint([ex]):= if ev(is(length(ex)>1),simp) then apply(nounify(int), ex) else error("int must have at least two arguments.")$ +noundiff([ex]):= if ev(is(length(ex)>1),simp) then apply(nounify(diff), ex) else error("diff must have at least two arguments.")$ +nounlimit([ex]):=apply(nounify(limit), ex)$ + +/* ********************************** */ +/* Add in a +- operator */ +/* ********************************** */ + +/* We have to define +- to be both a prefix and an nary operator in this order. */ +/* Note we need to add this into (defun tex-mexpt (x l r) in stacktex.lisp. */ +STACKpmOPT:"#pm#"; +prefix(STACKpmOPT); +nary(STACKpmOPT, 100); + +displaypmtex(ex):=block([al], + al:args(ex), + if is(length(al)=1) then + return(sconcat(" \\pm ", tex1(first(al)))), + al:maplist(tex1, al), + sconcat("{", simplode(al, " \\pm "), "}") + ); +texput(STACKpmOPT, displaypmtex); + +matchdeclare(pmpatex1,true); +matchdeclare(pmpatex2,true); +tellsimpafter(-(pmpatex1 #pm# pmpatex2),(-pmpatex1) #pm# pmpatex2); + +/* Count the occurance of an operator. */ +count_op(ex, ops):= block([count], + if atom(ex) then return(0), + /* Can't do a ev(..., simp) here as it will simplify ex to an atom. */ + count:apply("+", maplist(lambda([ex2], count_op(ex2, ops)), args(ex))), + if op(ex)=ops then return(1+count), + return(count) +)$ + +/* Replace +- with an explicit "or" version. + If +- occurs more than once this is fundamentally ambiguous. + Do we mean both + then both -, or all 4 combinations? +*/ +pm_replace(ex):= block( + if ev(is(count_op(ex, STACKpmOPT)=1), simp) then return(opsubst("+", STACKpmOPT, ex) nounor opsubst("-", STACKpmOPT, ex)), + return(ex) +)$ + +/* ********************************** */ +/* Abs removal functions */ +/* ********************************** */ + +/* Replace the first occurance of the A for B in ex. */ +opsubst_first(A, B, C):=block([ar, k], + if freeof(A, C) then return(C), + if equal(A, C) then return(B), + if atom(C) then return(C), + if equal(safe_op(C), string(A)) then return(apply(B, args(C))), + ar:args(C), + k:1, + while freeof(A, ev(ar[k], simp)) do k:ev(k+1, simp), + ar[k]:opsubst_first(A, B, ar[k]), + return(apply(op(C), ar)) +)$ + +/* Replace abs(x) with + %or - versions. */ +abs_replace(ex):=block([exc1, exc2, ret], + if freeof(abs, ex) then return(ex), + /* These copy commands must be outside the opsubst_first, otherwise the time taken explodes. */ + exc1:copy(ex), + exc2:copy(ex), + exc1:ineqprepare(opsubst_first(abs, "+", exc1)), + exc2:ineqprepare(opsubst_first(abs, "-", exc2)), + exc1:abs_replace(exc1), + exc2:abs_replace(exc2), + ret:ev(exc1 %or exc2, simp) +)$ + +/* Replace abs(x) in an equation or inequality, to possibly give a product of factors. */ +abs_replace_eq(ex):=block([exn, assume_pos], + /* In this function we don't want any extra simplification of variables. */ + assume_pos:false, + if freeof(abs, ex) then return(ex), + if not(equationp(ex)) then return(ex), + exn:ineqprepare(ex), + exn:abs_replace(exn), + if all_listp(equationp, args(exn)) then block( + exn:map(lhs, args(exn)), + exn:(apply("*", args(exn))=0) + ), + return(exn) +)$ + +/* ********************************** */ +/* Algebraic form */ +/* ********************************** */ + +/* expandp(p) is true if p equals its expanded form. */ +/* Use ev with the expand option to limit expansion of large powers .*/ +/* The use of a strange argument to this function is caused by an extra evaluation within the function body.*/ +expandp(expandparg):= block([simp:true], if expandparg=ev(expand(expandparg),expand(1000,1000)) then true else false)$ + +/* factorp(p) is true if p equals its factored form. */ +factorp(argfac) := block([a], + if safe_op(argfac)="-" then + argfac:part(argfac,1), + if ev(argfac=factor(argfac), simp) then + return(true), + if integerp(argfac) then + return(false), + if mapatom(argfac) then + return(true), + /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this. */ + if ev(-1*factor(argfac) = expand(-1*argfac), simp) then + return(true), + if op(argfac)="^" and mapatom(part(argfac, 1)) + then return(true), + if op(argfac)="^" and factorp(part(argfac, 1)) then + return(true), + if op(argfac)="*" then + return(all_listp(factorp, args(argfac))), + return(false) +)$ + +/* Write the polynomial in completed square form. */ +comp_square(ex,var) := block([vc], + if not(atom(var)) or numberp(var) then ( + error("comp_square: var should be an atom but not a number. "), + return(ex) + ), + ex:ratsimp(expand(ex)), + if not(polynomialp(ex, [var])) then ( + error("comp_square: ex should be a polynomial in var. "), + return(ex) + ), + if hipow(ex, var)#2 then ( + error("comp_square: ex should be a quadratic. "), + return(ex) + ), + delta:(coeff(ex, var, 1)^2-4*coeff(ex, var, 2)*coeff(ex, var, 0))/(4*coeff(ex, var, 2)^2), + vc:coeff(ex, var, 1)/(2*coeff(ex, var, 2)), + return(coeff(ex, var, 2)*((var+vc)^2-delta)) +)$ + +/* Return the bag of factors of the expression. I.e. strip away multiplicity of roots. */ +factor_bag(ex) := block( + if equationp(ex) then ex:ev(lhs(ex)-rhs(ex), simp), + if not(polynomialp(ex, listofvars(ex))) then return([ex]), + ex:ev(factor(ex), simp), + /* If we have division here, by a numerical constant being pulled out, we ignore the constant. */ + if safe_op(ex) = "/" then + if ev(is(listofvars(second(args(ex)))=[]), simp) then ex:first(args(ex)), + if safe_op(ex) = "^" then return([first(args(ex))]), + if safe_op(ex) = "*" then ex:args(ex) else ex:[ex], + /* Strip off any powers. */ + ex:maplist(lambda([ex2], if safe_op(ex2) = "^" then first(args(ex2)) else ex2), ex), + /* Remove any numbers. */ + ex:sublist(ex, lambda([ex2], ev(not(is(listofvars(ex2)=[])), simp))), + return(ex) +)$ + +/* Terms of the form [a]*v_1, where we have exactly one substantive term which satisfies the predicate p, multiplied by numbers. + Numbers on their own don't count here. +*/ +linear_term_p(ex, p) := block([ex1], + if p(ex) then return(true), + if not(safe_op(ex)="*") then return(false), + ex1:args(ex), + if not(length(sublist(ex1, p))=1) then return(false), + ex1:sublist(ex1, lambda([ex2], not(p(ex2)))), + return(all_listp(real_numberp, ex1)) +)$ + +/* Establishes if an expression is a linear combination of terms + for which the predicate p is true. +*/ +linear_combination_p(ex, p) := block( + if linear_term_p(ex, p) then return(true), + if not(safe_op(ex)="+") then return(false), + ex:args(ex), + ex:map(lambda([ex1], linear_term_p(ex1, p)), ex), + return(apply("and", ex)) +)$ + +/* + Write the polynomial ex, in variable v, about the point v=a. + Ex. x^2=1-2*(x-1)+(x-1)^2 when written about x=1. + This is basically the Taylor series for the polynomial about x=1, but + it can readily be calculated by "shift-expand-shift" and without derivatives. + See doi:10.1017/S0025557200003569 +*/ +poly_about_a(ex, v, a) := block( + if not(polynomialp(ex, [v])) then return(ex), + ex:ev(expand(ev(ex, ev(v)=''v+a)), simp), + return((ev(ex, ev(v)=''v-a))) +)$ + +/****************************/ +/* Matrix/vector operations */ +/****************************/ + + +/* Create an "ephemeral form" for vectors, much like stackunits. */ +texboldatoms(ex) := block( + if numberp(ex) then return(ex), + if atom(ex) then return(stackvector(ex)), + if arrayp(ex) then return(arraymake(op(ex), maplist(texboldatoms, args(ex)))), + apply(op(ex), maplist(texboldatoms, args(ex))) +)$ + +stackvectortex(ex):= block( + sconcat("{\\bf ", tex1(first(args(ex))), "}") +); +texput(stackvector, stackvectortex); + +/* Remove stackvectors. Needed for dispvalue. */ +destackvector(ex):= block([argsex], + if mapatom(ex) then return(ex), + argsex:args(ex), + if op(ex) = stackvector then return(destackvector(argsex[1])), + if op(ex) = "/" then return(destackvector(argsex[1])/destackvector(argsex[2])), + map(destackvector, ex) +)$ + +/* + Description : forme echelonne par lignes d'une matrice rectangulaire + (a coefficients dans un corps commutatif). + Taken from http://www.math.utexas.edu/pipermail/maxima/2007/008246.html +*/ + +request_rational_matrix(m, pos, fn) := + if every('identity, map(lambda([s], every('ratnump,s)), args(m))) then true else + print("Some entries in the matrix are not rational numbers. The result might be wrong.")$ + +rowswap(m,i,j) := block([n, p, r], + require_matrix(m, "first", "rowswap"), + require_integer(i, "second", "rowswap"), + require_integer(j, "third", "rowswap"), + n : length(m), + if (i < 1) or (i > n) or (j < 1) or (j > n) + then error("Array index out of bounds"), + p : copymatrix(m), + r : p[i], + p[i] : p[j], + p[j] : r, + p +)$ + +rowadd(m,i,j,k) := block([n,p], + require_matrix(m, "first", "rowadd"), + require_integer(i, "second", "rowadd"), + require_integer(j, "third", "rowadd"), + require_rational(k, "fourth", "rowadd"), + n : length(m), + if (i < 1) or (i > n) or (j < 1) or (j > n) + then error("Array index out of bounds"), + p : copymatrix(m), + p [i] : p[i] + k * p[j], + p +)$ + +rowmul(m,i,k) := block([n,p], + require_matrix(m, "first", "rowmul"), + require_integer(i, "second", "rowmul"), + require_rational(k, "fourth", "rowmul"), + n : length(m), + if (i < 1) or (i > n) then error("Array index out of bounds"), + p : copymatrix(m), + p [i] : k * p[i], + p +)$ + + +rref(m):= block([p,nr,nc,i,j,k,pivot,pivot_row,debug], + debug : 0, + request_rational_matrix(m," ","rref"), + nc: length(first(m)), + nr: length(m), + if nc = 0 or nr = 0 then + error ("The argument to 'rref' must be a matrix with one or more rows and columns"), + p:copymatrix(m), + ci : 1, cj : 1, + while (ci<=nr) and (cj<=nc) do + ( + if (debug = 1) then ( + disp(p), + print("curseur en ligne ",ci," et colonne ",cj)), + pivot_row : 0, pivot : 0, + for k : ci thru nr do ( + if ( abs(p[k,cj]) > pivot ) then ( + pivot_row : k, + pivot : abs(p[k,cj]))), + if (debug = 1) then + print("colonne ",cj," : pivot trouve ligne ", pivot_row,", valeur : ",pivot), + if (pivot = 0) then (cj : cj +1) + else ( + p : rowswap(p,ci,pivot_row), + if (debug = 1) then print (".. Echange : ",p), + p : rowmul(p,ci,1/p[ci,cj]), + if (debug = 1) then print (".. Normalisation : ",p), + for k : 1 thru nr do ( + if not (k=ci) then (p : rowadd(p,k,ci,-p[k,cj]))), + ci : ci+1, cj : cj+1)), + p +)$ + +crossproduct(a,b) := block( + if (not(is(safe_op(a)="matrix")) or not(is(safe_op(b)="matrix"))) then error("cossproduct requires matrices as arguments."), + if (not(is(matrix_size(a)=[3,1])) or not(is(matrix_size(b)=[3,1]))) then error("cossproduct requires 3*1 matrices."), + transpose(matrix([a[2,1]*b[3,1]-a[3,1]*b[2,1],a[3,1]*b[1,1]-a[1,1]*b[3,1],a[1,1]*b[2,1]-a[2,1]*b[1,1]])) +)$ + +/* ********************************** */ +/* Analysis tests */ +/* ********************************** */ + +/* This determines if an expression is continuous + ex the expression, + v the variable, + xp the point at which to evaluate. */ +continuousp(ex, v, xp) := block([lp, lm], + lp: ev(limit(ex, v, xp, minus), simp), + lm: ev(limit(ex, v, xp, plus), simp), + /* print(lp), print(lm), */ + if lp # und + and lm # und + and lp # ind + and lm # ind + and lp # inf + and lm # inf + and lp # minf + and lm # minf + and lp = lm + then true else false +)$ + + +/* This determines if an expression is differentiable + ex the expression, + v the variable, + xp the point at which to evaluate, + n the number of times it is differentiated (optional). +*/ +diffp(ex,[args]) := block([v, xp, n], + v:args[1], + xp:args[2], + n:1, + if length(args)=3 then n:args[3], + return(continuousp(diff(ex, v, n), v, xp)) +)$ + +/* ********************************** */ +/* Buggy rules */ +/* ********************************** */ + + +/* (a+b)^n -> a^n+b^n */ +buggy_pow(ex) := block([ex_ex], + if mapatom(ex) then return(ex), + if op(ex)="/" and atom(part(ex, 2))#true and op(part(ex, 2))="+" then return(map(lambda([ex2],part(ex, 1)/ex2), part(ex, 2))), + if mapatom(part(ex, 1)) or op(part(ex, 1))#"+" then return(map(buggy_pow, ex)), + if op(ex)="^" then return(map(lambda([ex2], ex2^buggy_pow(part(ex, 2))), map(buggy_pow, part(ex, 1)))), + if op(ex)=sqrt then return(map(sqrt, map(buggy_pow, part(ex, 1)))) +)$ + +/* Naive adding of fractions! But see Farey sequences. */ +mediant(ex1,ex2) := (num(ex1)+num(ex2))/(denom(ex1)+denom(ex2)); + +/***********************************************************************/ +/* Establish an argument and display it together with equivalences. */ +/***********************************************************************/ + +texput(EMPTYCHAR, " "); +texput(EQUIVCHAR, "\\color{green}{\\Leftrightarrow}"); +texput(EQUIVLOG, "\\color{green}{\\log(?)}"); +texput(EQUIVCHARREAL, "\\color{green}{\\Leftrightarrow}\\, \\color{blue}{(\\mathbb{R})}"); +texput(CHECKMARK, "\\color{green}{\\checkmark}"); +texput(IMPLIESCHAR, "\\color{red}{\\Rightarrow}"); +texput(IMPLIEDCHAR, "\\color{red}{\\Leftarrow}"); +texput(PLUSC, "\\color{red}{\\cdots +c\\quad ?}"); +texput(EQUIVZERO, "\\color{red}{0\\quad\\text{(?)}}"); +/* Here we add tags. These are for localisation. Dealt with on the PHP side in cassession -> instantiate. */ +texput(SAMEROOTS, "\\color{green}{\\text{!SAMEROOTS!}}"); +texput(ANDOR, "\\color{red}{\\text{!ANDOR!}}"); +texput(MISSINGVAR, "\\color{red}{\\text{!MISSINGVAR!}}"); +texput(ASSUMEPOSVARS, "\\color{blue}{\\text{!ASSUMEPOSVARS!}}"); +texput(ASSUMEREALVARS, "\\color{blue}{(\\mathbb{R})}"); +texput(ASSUMEPOSREALVARS, "\\color{blue}{\\text{!ASSUMEPOSREALVARS!}}"); +/* For now we suppress this. */ +texput(unknown, " "); + +DIFFCHARtex(ex):=block( + sconcat("\\color{blue}{\\frac{\\mathrm{d}}{\\mathrm{d}", tex1(first(args(ex))), "}\\ldots}") +); +texput(DIFFCHAR, DIFFCHARtex); +INTCHARtex(ex):=block( + sconcat("\\color{blue}{\\int\\ldots\\mathrm{d}", tex1(first(args(ex))), "}") +); +texput(INTCHAR, INTCHARtex); + +EQUATECOEFFLOSStex(ex):=block( + sconcat("\\color{green}{\\equiv (\\cdots ? ", tex1(first(args(ex))), ")}") +); +texput(EQUATECOEFFLOSS, EQUATECOEFFLOSStex); +EQUATECOEFFGAINtex(ex):=block( + sconcat("\\color{green}{(\\cdots ? ", tex1(first(args(ex))), ")\\equiv}") +); +texput(EQUATECOEFFGAIN, EQUATECOEFFGAINtex); + +/* We assume the token "all" is the set of real numbers, and "none" means it is empty. */ +declare(all, constant); +texput(all, "\\mathbb{R}"); + +declare(none, constant); +texput(none, "\\emptyset"); + +/* stackeq is an inert prefix equality symbol. */ +stackeqtex(ex):=block( + sconcat("=", tex1(first(args(ex)))) +); +texput(stackeq, stackeqtex); + +/* Remove the stackeq operator. */ +remove_stackeq(ex) := if is(safe_op(ex)="stackeq") then first(args(ex)) else ex$ + +/* stacklet is an inert "let" operator, e.g. let x=1. */ +stacklettex(ex):=block( + sconcat("\\text{!LET! }", tex1(first(args(ex))), " = ", tex1(second(args(ex)))) +); +texput(stacklet, stacklettex); + +/* This function actually evaluates the correctness of an argument "ex". */ +/* It answers the question, "Is this list of steps correct reasoning by equivalence?". */ +/* Display, fitness to a model and other functions are separate, and all rely on this. */ +/* Each line of the matrix is as follows: */ +/* [equiv?, symbol, expression, note]. */ +/* Where */ +/* Boolean: equiv is whether this line is equivalent to the **previous** line. Line 1 is true. */ +/* Expr: symbol, is a symbol which may or may not be displayed. */ +/* Expr: expression, is the line of the argument. */ +/* String: note is some deugging information. */ +stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargument, tempnote, exmod, exmodpoly, exmodsolve, exnatdomain, SA, SAL, SB, SBL, malrulecont], + if not(listp(ex)) then error("stack_eval_arg expects to receive a list."), + if emptyp(ex) then return(matrix([true, EMPTYCHAR, [], EMPTYCHAR, ""])), + if length(ex)=1 then return(matrix([true, EMPTYCHAR, first(ex), EMPTYCHAR, ""])), + /* Set up empty rows to hold the answer. */ + eqoutcome:makelist(false, length(ex)), + eqoutsymb:makelist(QMCHAR, length(ex)), + eqoutnote:makelist("", length(ex)), + eqoutcome[1]:null, + eqoutsymb[1]:EMPTYCHAR, + if assume_pos then eqoutsymb[1]:ASSUMEPOSVARS, + if assume_real then eqoutsymb[1]:ASSUMEREALVARS, + if assume_pos and assume_real then eqoutsymb[1]:ASSUMEPOSREALVARS, + + /* STAGE A: Loop and sort out expressions. */ + exmod:copy(ex), + exmodpoly:copy(ex), + exmodsolve:copy(ex), + /* Copy the expressions here, so we have the natural domain of the original expression. */ + exnatdomain:copy(ex), + for id:1 thru length(ex) step 1 do block([SA, tempnote:""], + SA:exmod[ev(id, simp)], + if stack_eval_arg_equivzerop(ex) then SA:SA=0, + if is(safe_op(SA)="stackeq") then SA:first(args(SA)), + if ev(is(count_op(SA,STACKpmOPT)=1), simp) then SA:pm_replace(SA), + + /* Reduce the range of options. Avoid sets, since Maxima 5.38.1 has a bug. */ + /* As far as resoning by equivalence is concerned, {}=[]=false=none and true=all. */ + if is(emptyp(SA)) or is(SA=false) then SA:none, + if is(SA=true) then SA:all, + + SA:abs_replace_eq(SA), + SA:ev(SA, lg=logbasesimp), + exmod[ev(id, simp)]:SA, + exmodsolve[ev(id, simp)]:stack_eval_arg_solver(SA), + + /* Try to turn things into polynomials. Much more reliable equivalence checking. */ + /* End up in the form p(x) = 0 */ + if (logicp(SA)) then block( + SA:ev(logic_to_poly(SA), simp) + ), + exmodpoly[ev(id, simp)]:SA + ), + + if debug then print("Modified list: ", exmod), + if debug then print("To poly list: ", exmodpoly), + if debug then print("Solved: ", exmodsolve), + + /* STAGE B: Loop and check adjacent expressions for equivalence. */ + for id:2 thru length(ex) step 1 do block([ATres, SA, SB, SAP, SBP, SAS, SBS, SAL, SBL], + tempnote:"", + SA:exmod[ev(id-1, simp)], + SB:exmod[ev(id, simp)], + + SAP:exmodpoly[ev(id-1, simp)], + SBP:exmodpoly[ev(id, simp)], + SAS:exmodsolve[ev(id-1, simp)], + SBS:exmodsolve[ev(id, simp)], + + if (debug) then print("-------------------------------"), + if (debug) then print("Line: ", ev(id-1,simp)), + + /* Work back to find the previous real expression. */ + if safe_op(SA) = "stacklet" and is(id>2) then block([k1, k2, l:[]], + k1:ev(id-1,simp), + ev(for k2:(id-1) step -1 while (is(k2>1) and is(safe_op(exmod[k2]) = "stacklet")) do block( + l:append([first(args(exmod[k2]))=second(args(exmod[k2]))], l), + k1:k2 + ), simp), + if (debug) then print("Detected stacklet. Going back to line ", string(ev(k1-1, simp))), + if (debug) then print("Got lets: ", string(l)), + SA:ev(exmod[ev(k1-1,simp)], l), + SAP:ev(exmodpoly[ev(k1-1,simp)], l), + SAS:ev(exmodsolve[ev(k1-1,simp)], l) + ), + + if (debug) then print("SA: ", SA), + if (debug) then print("SB: ", SB), + if (debug) then print("SAP: ", SAP), + if (debug) then print("SBP: ", SBP), + if (debug) then print("SAS: ", SAS), + if (debug) then print("SBS: ", SBS), + /* Strings break up an argument into independent blocks. */ + if stringp(SA) or stringp(SB) then block( + eqoutsymb[ev(id, simp)]:EMPTYCHAR, + eqoutcome[ev(id, simp)]:unknown + ) else if safe_op(SB) = "stacklet" then block( + eqoutsymb[ev(id, simp)]:EMPTYCHAR, + eqoutcome[ev(id, simp)]:true + ) else ( + malrulecont:true, + /* Now check for equivalences. */ + tempnote:sconcat(tempnote, "SAS: ", string(SAS), "; "), + tempnote:sconcat(tempnote, "SBS: ", string(SBS), "; "), + if (debug) then print("Solved as ", string(SAS), ", ", string(SBS)), + if (debug) then print("ATAlgEquiv(", string(SAP), ", ", string(SBP), ");"), + if is(SAS=SBS) then block + ([FAA, FAB, PECret], + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | Solved_true"), + /* At this point we need to check for SAMEROOTS. We do use the polynomial form. + This means logic goes to polys, e.g. x=1 or x=1 -> (x-1)^2=0, but we don't loose multiplicity. */ + FAA:if equationp(SAP) then ev(lhs(SAP)-rhs(SAP), simp) else SAP, + FAB:if equationp(SBP) then ev(lhs(SBP)-rhs(SBP), simp) else SBP, + if (debug) then print("Check for SAMEROOTS with: ", string(FAA), ", ", string(FAB)), + if ev(is(polynomialpsimp(FAA) and polynomialpsimp(FAB)), simp) then block([facbA, facbB], + ATres:ev(ATAlgEquiv(SAP, SBP), simp), + if (debug) then print("SAMEROOTS first ATAlgEquiv check: ", SAP, ", ", SBP, " gave ", ATres), + /* In this case we establish they are *not* algebraically equivalent. */ + if not(second(ATres)) then block( + facbA:factor_bag(SAP), + facbB:factor_bag(SBP), + if (debug) then print("Factor bags: ", string(facbA), "; ", string(facbB), "; "), + facbA:apply("*", facbA), + facbB:apply("*", facbB), + ATres:ev(ATAlgEquiv(facbA, facbB), simp), + if (debug) then print("Are the factor bags algebraically eqivalent? ", ATres), + if second(ATres) then block( + eqoutsymb[ev(id, simp)]:SAMEROOTS, + tempnote:sconcat(tempnote, " | SAMEROOTS | ", third(ATres)) + ) + ) + ) + ) else /* Needs to come before checking subsets. Special case of real single variable equations. */ + if assume_real then block([FAA, FBB, FGCD, ATres], + FAA:if equationp(SAP) then lhs(SAP)-rhs(SAP) else SAP, + FAB:if equationp(SBP) then lhs(SBP)-rhs(SBP) else SBP, + if (debug) then print("** Checking assume_real with: ", string(FAA), ", ", string(FAB), " **"), + if (polynomialpsimp(FAA) and polynomialpsimp(FAB) and length(listofvars(FAA))=1 and length(listofvars(FAB))=1) then block( + FAA:ev(solve(FAA), simp), + FAB:ev(solve(FAB), simp), + if (debug) then print("Solved as ", string(FAA), ", ", string(FAB)), + FAA:ev(sublist(FAA, lambda([ex2], real_numberp(rhs(ex2))))), + FAB:ev(sublist(FAB, lambda([ex2], real_numberp(rhs(ex2))))), + if (debug) then print("Filtered as ", string(FAA), ", ", string(FAB)), + if sort(FAA)=sort(FAB) then block + ( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHARREAL + ) + ) + ) + else + /* Check for subsets. */ + if safe_op(SAS)="realset" and safe_op(SBS)="realset" and is(first(args(SAS))=first(args(SBS))) then block + ( + if (debug) then print("Found two realset, checking for subsets. ", string(SAS), ", ", string(SBS)), + if not(SAS=SBS) and setp(second(args(SAS))) and setp(second(args(SBS))) then + if ev(subsetp(second(args(SAS)), second(args(SBS))), simp) then block + ( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIESCHAR, + tempnote:sconcat(tempnote, " | Solved IMPLIES ") + ) + elseif ev(subsetp(second(args(SBS)), second(args(SAS))), simp) then block + ( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIEDCHAR, + tempnote:sconcat(tempnote, " | Solved IMPLIED ") + ) + ) + else + if safe_setp(SAS) and safe_setp(SBS) then block + ( + if (debug) then print("Found two sets, checking for subsets. ", string(SAS), ", ", string(SBS)), + if not(SAS=SBS) then + if ev(subsetp(SAS, SBS), simp) then block + ( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIESCHAR, + tempnote:sconcat(tempnote, " | Solved IMPLIES set") + ) + elseif ev(subsetp(SBS, SAS), simp) then block + ( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIEDCHAR, + tempnote:sconcat(tempnote, " | Solved IMPLIED set") + ) + ), + + + if (malrulecont) then block + ( + ATres:ev(ATAlgEquiv(SAP, SBP), simp), + tempnote:sconcat(tempnote, "SAP: ", string(SAP), "; "), + tempnote:sconcat(tempnote, "SBP: ", string(SBP), "; "), + if (debug) then print(ATres), + if second(ATres) then block + ( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | ATAlgEquiv_true | ", third(ATres)) + ), + + /* Check for equating coefficients. */ + if (debug) then print("Check for Equating coefficients with: ", string(SAP), ", ", string(SBP)), + PECret:ev(poly_equate_coeffsp(SAP, SBP), simp), + if (debug) then print("Equating coefficients result: ", string(PECret)), + if not(is(PECret=false)) then block + ( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:PECret, + tempnote:sconcat(tempnote, " | EquateCoeffs | ", string(PECret)) + ), + + + /* Deal with special cases with assume_pos. */ + if assume_pos then block + ( + if (debug) then print("** Checking for assume_pos **"), + if (debug) then print("ATAlgEquiv(", string(SA^2), ", ", string(abs(SB)), ");"), + ATres:ev(ATAlgEquiv(SA^2, abs(SB)), simp), + if (debug) then print(ATres), + if second(ATres) then block + ( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | assume_pos_sq_abs | ", third(ATres)) + ), + if (debug) then print("ATAlgEquiv(", string(abs(SA)), ", ", string(SB^2), ");"), + ATres:ev(ATAlgEquiv(abs(SA), SB^2), simp), + if (debug) then print(ATres), + if second(ATres) then block + ( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | assume_pos_abs_sq | ", third(ATres)) + ) + ) + ), + + malrulecont:not(eqoutcome[ev(id, simp)]), + /* In the edge cases we don't look for malrules. Edge cases are turned into equations. */ + if is(lhs(SA)=all) or is(lhs(SB)=all) or is(lhs(SA)=none) or is(lhs(SB)=none) then + malrulecont:false, + /* Has the student done explicit calculus? */ + if is(stack_calculus=true) then block([SAN, SBN, SAD, SBD, var, ATres], + if (debug) then print("** Has the student done explicit calculus? **"), + if (debug) then print(SA), + if (debug) then print(SB), + SAN:ev(SA, nouns, simp), + SBN:ev(SB, nouns, simp), + if equationp(SAN) then SAN:lhs(SAN)-rhs(SAN), + if equationp(SBN) then SBN:lhs(SBN)-rhs(SBN), + if (debug) then print("Calculated values as SA->", string(SAN), ", SB->", string(SBN)), + if ev(not(freeof('int, SA)), simp) then block([var], + if (debug) then print("(1) Did the student integrate?"), + var:first(ATIntGetVar(SA)), + if (debug) then print("START ATInt -----------------"), + ATres:ev(ATInt(SBN, SAN, var), simp), + if (debug) then print("END ATInt -----------------"), + if (debug) then print("Calculated ATInt ", string(ATres)), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:INTCHAR(var), + tempnote:sconcat(tempnote, " | Integrated explicitly (1)") + ), + if (ev(freeof('int, SB), simp) and is(third(ATres)="ATInt_const. ")) then block ( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:PLUSC, + tempnote:sconcat(tempnote, " | ATInt_const. ") + ) + ), + if ev(not(freeof('int, SB)), simp) then block([var], + if (debug) then print("(2) Did the student integrate?"), + var:first(ATIntGetVar(SB)), + ATres:ev(ATAlgEquiv(SA, diff(SB, var)), simp), + if (debug) then print("Calculated ATInt ", string(ATres)), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:INTCHAR(var), + tempnote:sconcat(tempnote, " | Integrated explicitly (2)") + ) + ), + if ev(not(freeof('diff, SB)), simp) then block([var], + if (debug) then print("(3) Did the student differentiate?"), + var:first(ATDiffGetVar(SB)), + ATres:ev(ATAlgEquiv(diff(SA, var), SB), simp), + if (debug) then print("Calculated ATDiff ", string(ATres)), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:DIFFCHAR(var), + tempnote:sconcat(tempnote, " | Differentiated explicitly (1)") + ) + ) + ), + + /* Can we work out what has gone wrong? */ + if (debug) then block( + if (malrulecont) then block( + print("** Checking for common mistakes **"), + print(SA), + print(SB) + ) else + print("** Not actually checking for common mistakes ... **") + ), + + /* The following rules are only checked when we have no calculus operations. */ + malrulecont:malrulecont and freeof(int,SA) and freeof(int,SB) + and freeof(diff,SA) and freeof(diff,SB), + + /* We don't allow the stackeq operator for the second argument with calculus. */ + if malrulecont and is(stack_calculus=true) and not(safe_op(ex[ev(id, simp)])="stackeq") then block([SAN, SBN, SAD, SBD, var, ATres], + /* (C0) Implicit calculus operations. */ + if (debug) then print("** Inferring Calculus **"), + var:last(sort(listofvars(SA))), + SAN:ev(SA, nouns, simp), + SAD:ev(diff(SAN,var), simp), + SBN:ev(SB, nouns, simp), + SBD:ev(diff(SBN,var), simp), + if (debug) then print("Calculated values as SA->", string(SAN), ", SB->", string(SBN)), + if (debug) then print("Calculated derivatives as SA->", string(SAD), ", SB->", string(SBD), " wrt ", var), + ATres:ev(ATAlgEquiv(SAD, SB), simp), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:DIFFCHAR(var), + tempnote:sconcat(tempnote, " | Differentiated ") + ) else ( + ATres:ev(ATAlgEquiv(SA, SBD), simp), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:INTCHAR(var), + tempnote:sconcat(tempnote, " | Integrated ") + ) else ( + /* Check if a constant of integration is missing? */ + ATres:ev(ATAlgEquiv(SAD, SBD), simp), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:INTCHAR(var), + tempnote:sconcat(tempnote, " | IntegratedConst ") + ) + ) + ) + ), + + if malrulecont then block([FAA, FBB, FGCD, ATres], + /* (0) Multiplicity of roots. */ + /* (1) Look at the GCD. */ + FAA:if equationp(SAP) then lhs(SAP)-rhs(SAP) else SAP, + FAB:if equationp(SBP) then lhs(SBP)-rhs(SBP) else SBP, + if (debug) then print("Possible multiplicity and GCD with: ", string(FAA), ", ", string(FAB)), + if ev(is(polynomialpsimp(FAA) and polynomialpsimp(FAB)), simp) then block([facbA, facbB, FGCD], + /* We know at this point FAA and FAB are not equivalent, so they will not both equal the gcd. */ + if (debug) then print("Considering GCD of ", string(FAA), " and ", string(FAB), "."), + FGCD:ev(gcd(FAA,FAB), simp), + if (debug) then print("Calculated GCD as: ", FGCD), + ATres:ev(ATAlgEquiv(FAA=0, FGCD=0), simp), + if (debug) then print(ATres), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIESCHAR, + tempnote:sconcat(tempnote, " | GBD-IMPLIES | ", third(ATres)) + ) else ( + ATres:ATAlgEquiv(FAB=0, FGCD=0), + if (debug) then print(ATres), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIEDCHAR, + tempnote:sconcat(tempnote, " | GBD-IMPLIED | ", third(ATres)) + ) + ) + ) + ), + + if malrulecont then block([FBA, ATres], + /* (1.1.and) And/or errors. */ + FBA:exmod[ev(id, simp)], + if (debug) then print("(1.1.and) and/or errors: ", string(FBA), SA), + if safe_op(FBA) = "nounand" then block( + FBA:apply("nounor", args(FBA)), + ATres:ev(ATLogic(SA, FBA), simp), + if (debug) then print("Checking for AND/OR:", ATres), + if (second(ATres)) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:ANDOR, + tempnote:sconcat(tempnote, " | ANDOR ") + ) + ) + ), + + if malrulecont then block([FBA, ATres], + /* (1.1.or) And/or errors. */ + FBA:exmod[ev(id, simp)], + if (debug) then print("(1.1.or) and/or errors: ", string(FBA), SA), + if safe_op(FBA) = "nounor" then block( + FBA:apply("nounand", args(FBA)), + ATres:ev(ATLogic(SA, FBA), simp), + if (debug) then print("Checking for AND/OR:", ATres), + if (second(ATres)) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:ANDOR, + tempnote:sconcat(tempnote, " | ANDOR ") + ) + ) + ), + + if malrulecont then block([FBA, ATres], + /* (1.3) MISSINGVAR. */ + FBA:stack_validate_missing_assignment(SB), + if (debug) then print("MISSINGVAR: ", string(FBA)), + if first(FBA) then block( + FBA:second(FBA), + ATres:ev(ATLogic(SA, FBA), simp), + if (debug) then print("Checking for MISSINGVAR", [SA, FBA]), + if second(ATres) then block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:MISSINGVAR, + tempnote:sconcat(tempnote, " | MISSINGVAR ") + ) + ) + ), + + /* Keep the explicit squaring of both sides to remove square roots. */ + if malrulecont then block([FBA, ATres], + /* (2) Squared first side. */ + FBA:ev(SA^2,simp), + if (debug) then print("ATAlgEquiv(", string(FBA), ", ", string(SB), ");"), + ATres:ev(ATAlgEquiv(FBA, SB), simp), + if (debug) then print(ATres), + if second(ATres) then block( + malrulecont:false, + if assume_pos then block( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | SquaredFirstEquiv | ", third(ATres)) + ) else block( + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIESCHAR, + tempnote:sconcat(tempnote, " | SquaredFirst | ", third(ATres)) + ) + ) + ), + + if malrulecont then block([FBB, ATres], + /* (3) Squared second. */ + FBB:ev(SB^2,simp), + if (debug) then print("ATAlgEquiv(", string(SA), ", ", string(FBB), ");"), + ATres:ev(ATAlgEquiv(SA, FBB), simp), + if (debug) then print(ATres), + if second(ATres) then block( + if assume_pos then block( + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVCHAR, + tempnote:sconcat(tempnote, " | SquaredSecondEquiv | ", third(ATres)) + ) else block( + malrulecont:false, + eqoutcome[ev(id, simp)]:false, + eqoutsymb[ev(id, simp)]:IMPLIEDCHAR, + tempnote:sconcat(tempnote, " | SquaredSecond | ", third(ATres)) + ) + ) + ), + + if malrulecont then block([FBB, ATres], + /* (4) Log second. */ + /* Errcatch to avoid log(0) errors.... */ + FBB:errcatch(ev(log(SB),simp)), + if is(FBB = []) then (print("STACK: ignore previous error. (EQUIVLOG)")), + if not(emptyp(FBB)) then block( + /* Errcatch to avoid log(0) errors.... */ + ATres:errcatch(ev(ATAlgEquiv(SA, first(FBB)), simp)), + if is(ATres = []) then (print("STACK: ignore previous error. (EQUIVLOG)")), + if (debug) then print(ATres), + if not(emptyp(ATres)) and second(first(ATres)) then block( + ATres:first(ATres), + malrulecont:false, + eqoutcome[ev(id, simp)]:true, + eqoutsymb[ev(id, simp)]:EQUIVLOG, + tempnote:sconcat(tempnote, " | LogSecondEquiv | ", third(ATres)) + ) + ) + ) + ), + eqoutnote[ev(id, simp)]:tempnote, + if (debug) then print("Outcome: ", eqoutcome[ev(id, simp)]), + if (debug) then print("Note: ", eqoutnote[ev(id, simp)]) + ), + /* Equational reasoning where the first line is an equation, and then every line starts with =s. */ + if equationp(ex[1]) and all_listp(lambda([ex2], is(safe_op(ex2)="stackeq")), rest(ex)) then block( + eqoutnote[1]:sconcat(eqoutnote[1], "A=B, =C, ..."), + if second(ATAlgEquiv(lhs(ex[1]), rhs(ex[1]))) then block( + eqoutcome[1]:true, + eqoutsymb[1]:CHECKMARK + ) else block( + eqoutcome[1]:false, + eqoutsymb[1]:QMCHAR + ), + if second(ATAlgEquiv(rhs(ex[1]), first(args(ex[2])))) then block( + eqoutcome[2]:true, + eqoutsymb[2]:CHECKMARK + ) else block( + eqoutcome[2]:false, + eqoutsymb[2]:QMCHAR + ) + ), + /* Optimize symbols when equational reasoning. */ + for k:1 thru length(ex) step 1 do block( + if is(safe_op(ex[ev(k,simp)])="stackeq") and is(eqoutsymb[ev(k,simp)]=EQUIVCHAR) then + eqoutsymb[ev(k,simp)]:CHECKMARK + ), + /* Display natural domains. */ + if showdomain then block( + for k:1 thru length(ex) step 1 do block([natdom], + natdom:ev(natural_domain(exnatdomain[k]), simp), + exnatdomain[ev(k,simp)]:EMPTYCHAR, + if not(is(natdom=all) or is(natdom=unknown)) then + exnatdomain[ev(k,simp)]:texcolorplain("blue", natdom) + ) + ) else block( + /* The expressions are stored in exnatdomain up to this point. */ + for k:1 thru length(ex) step 1 do block( + exnatdomain[ev(k,simp)]:EMPTYCHAR + ) + ), + res:matrix(eqoutcome, eqoutsymb, ex, exnatdomain, eqoutnote), + return(transpose(res)) +)$ + +/* Try to find a representative of the solution set of the underlying system in a sensible form. + Only support specific situations currently. +*/ +stack_eval_arg_solver(ex) := block([ex2, ex3, errc], + + ex:logic_to_poly(ex), + + if ev(is(equal(length(listofvars(ex)), 1)), simp) then + return(ev(stack_single_variable_solver(ex), simp)), + + if safe_op(ex) = "%or" or safe_op(ex) = "nounor" or safe_op(ex) = "or" then + return(ev(logical_normal(apply("%or", maplist(stack_eval_arg_solver, ex))), simp)), + + if safe_op(ex) = "%and" or safe_op(ex) = "nounand" or safe_op(ex) = "and" then block([ex2], + /* Solve systems of polynomial equations. (Not inequalities) */ + ex2:maplist(logic_to_poly, args(ex)), + if (all_listp(lambda([ex], equationp(ex) and polynomialpsimp(lhs(ex))), ex2)) then block( + /* Algsys throws errors if we have too many variables, and in other situations. */ + ex3:[], + errc:errcatch(ex3:ev(solve(ex2, sort(listofvars(ex2))), simp)), + if not(emptyp(ex3)) then block( + if assume_real then + ex3:ev(sublist(ex3, lambda([m], freeof(%i, m))), simp), + if not(emptyp(ex3)) then (ex3:map(lambda([ex], apply("%and", ex)), ex3), ex:apply("%or", ex3)) + ) + ) + ), + return(ev(logical_normal(ex), simp)) +)$ + +/* This modifies stack_eval_arg to create something which can be displayed. */ +stack_eval_equiv_arg(ex, showlogic, showdomain, equivdebug, debuglist) := block([A, k, ret, res, exnew, eqoutsymb, note], + /* Evaluate the argument. */ + A:transpose(stack_eval_arg(ex)), + /* Decide if the overall argument is true. */ + res:first(A), + /* Remove first entry when this has not been set. */ + if first(res)=null then res:rest(res), + if elementp(unknown, setify(res)) then + /* For now, "unknown" is triggered by strings/comments. So this argument is not true. */ + res:false + else + res:apply("and", res), + /* If in debug mode check if we have what we expect. */ + eqoutsymb:A[2], + /* Modify input expressions for implied equivalence to zero. */ + exnew:A[3], + /* Unit test the eval_arg code. */ + if listp(debuglist) then block([simp, eqoutsymb, k], + eqoutsymb:A[2], + if is(length(eqoutsymb)=length(debuglist)) then block([simp], + simp:true, + for k:2 thru length(eqoutsymb) step 1 do block([ATres, SA, SB], + if not(is(eqoutsymb[k]=debuglist[k])) then + ( + eqoutsymb[k]:[eqoutsymb[k], expected(debuglist[k])], + res:fail + ) + ) + ) else ( + error("disp_stack_eval_arg: length of debuglist is ", string(length(debuglist)), ", but the length of the argument is ", string(length(eqoutsymb)), ".") + ) + ), + /* Only add in EQUIVZERO when we don't have equational reasoning and when we do have more than one line. */ + if stack_eval_arg_equivalence_reasoningp(A[3]) then + exnew:maplist(lambda([ex2], if stack_eval_arg_equivzerop(ex2) then ex2=EQUIVZERO else ex2), A[3]), + /* Turn "and" opertors into displayed ones. */ + exnew:maplist(lambda([ex2], if safe_op(ex2)="nounand" then apply(argumentand, args(ex2)) else ex2), A[3]), + /* Add in the natural domain information. */ + ret:append([exnew], [A[4]]), + /* If we are not showing logical connectives, then suppress them. */ + if showlogic then ret:append([eqoutsymb], ret), + if equivdebug then ret:append(ret, [A[5]]), + /* Switch off matrix brackets. */ + lmxchar:"", + ret:apply(matrix, ret), + ret:transpose(ret), + ret:apply(argument, args(ret)), + /* Construct a separate note. The note should be the same length as the argument, so normally has "EMPTYCHAR" as the first entry.*/ + /* If we return a list, then the PHP unpacking side now has problems, but we want to encapsulate the note as a single object, without | characters */ + note:sconcat("(", simplode(second(A), ","), ")"), + return([res, ret, note]) +)$ + +/* A predicate to decide if we should equate to zero. */ +stack_eval_arg_equivzerop(ex) := block( + if is(ex=true) or is(ex=false) then return(false), + if emptyp(ex) or is(ex=all) then return(false), + if expressionp(ex) and not(stringp(ex)) then return(true), + return(false) +)$ + +/* A predicate to distinguish between equational reasoning and equivalence reasoning. */ +/* Reasoning by equivalence uses equivalence of equations. Equational reasoning is a chain of =s. */ +stack_eval_arg_equivalence_reasoningp(L) := block( + if is(length(L<=1)) then return(false), + if op_usedp(L, stackeq) then return(false), + /* We use the rest of the list because we could have an answer like "[(x-1)^2=(x-1)*(x-1), stackeq(x^2-2*x+1)]". */ + if all_listp(lambda([ex], expressionp(ex) or is(safe_op(ex)="stackeq")), rest(L)) then return(false), + return(true) +)$ + +/* This modifies stack_eval_arg to create something which can be displayed. */ +disp_stack_eval_arg(ex, showlogic, showdomain, equivdebug, debuglist) := block([A], + A:stack_eval_equiv_arg(ex, showlogic, showdomain, equivdebug, debuglist), + return(second(A)) +)$ + +/* Find the indices of where ex appears in exl. + Notes: + (1) Uses ATEqualComAss, + (2) Ignores completely if "stackeq" is the first operator. + Returns a list of indices. + Use emptyp to create a predicate. +*/ +stack_equiv_find_step(ex, exl) := block( + if not(listp(exl)) then error("STACK function stack_equiv_find_step expects its second argument to be a list."), + if safe_op(ex)="stackeq" then ex:first(args(ex)), + exl:maplist(lambda([ex2], if safe_op(ex2)="stackeq" then first(args(ex2)) else ex2), exl), + sublist_indices(exl, lambda([ex2], second(ATEqualComAss(ex, ex2)))) +)$ + +/* This modifies stack_eval_arg to create something which can be displayed. */ +stack_disp_arg([exs]) := block([A], + ex:first(exs), + showlogic:true, + if length(exs)>1 then showlogic:second(exs), + showdomain:true, + if length(exs)>2 then showdomain:third(exs), + A:stack_eval_equiv_arg(ex, showlogic, showdomain, false, false), + return(second(A)) +)$ + +check_stack_eval_arg(ex) := block([ret], + /* Evaluate the argument. */ + if length(ex)<2 then return(true), + ret:stack_eval_equiv_arg(ex, false, false, false, false), + return(first(ret)) +)$ + +/* An answer test based on equivalence reasoning. */ +ATEquiv([ex]) := block([SA, SB, SO, SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false], + SA:first(ex), + SB:second(ex), + SO:[], + if length(ex)>2 then SO:third(ex), + + /* Turn on simplification and error catch. */ + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATEquiv_STACKERROR_SAns"), ""]), + SAB:errcatch(ev(SB, simp, nouns)), + if (is(SAB=[STACKERROR]) or is(SAB=[])) + then return([false, false, StackAddNote("", "ATEquiv_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(SO, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATEquiv_STACKERROR_Opt"), ""]), + + if listp(SO) then opts:setify(SO) else opts:{SO}, + if elementp(assumepos, opts) then assume_pos:true, + if elementp(assumereal, opts) then assume_real:true, + if elementp(calculus, opts) then stack_calculus:true, + + /* Are both answers lists? */ + if not listp(SA) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquiv_SA_not_list"))), + if not listp(SB) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquiv_SB_not_list"))), + + /* Actually perform the test. */ + A:stack_eval_equiv_arg(SA, true, true, false, false), + AnswerNote:third(A), + FeedBack:stack_disp(second(A), "d"), + + ret:[true, first(A), AnswerNote, FeedBack], + return(ret) +)$ + +/* An answer test based on equivalence reasoning. */ +ATEquivFirst([ex]) := block([SA, SB, SO, SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false], + SA:first(ex), + SB:second(ex), + SO:[], + if length(ex)>2 then SO:third(ex), + + /* Turn on simplification and error catch. */ + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATEquivFirst_STACKERROR_SAns"), ""]), + SAB:errcatch(ev(SB, simp, nouns)), + if (is(SAB=[STACKERROR]) or is(SAB=[])) + then return([false, false, StackAddNote("", "ATEquivFirst_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(SO, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATEquivFirst_STACKERROR_Opt"), ""]), + + if listp(SO) then opts:setify(SO) else opts:{SO}, + if elementp(assumepos, opts) then assume_pos:true, + if elementp(assumereal, opts) then assume_real:true, + if elementp(calculus, opts) then stack_calculus:true, + + /* Is the first argument a list? */ + if not listp(SA) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquivFirst_SA_not_list"))), + + /* Are both answers lists? */ + if not listp(SA) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquivFirst_SA_not_list"))), + if not listp(SB) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquivFirst_SB_not_list"))), + + ret:ATEqualComAss(first(SA), first(SB)), + if not(second(ret)) then + return([false, false, "ATEquivFirst_SA_wrong_start", StackAddFeedback("", "ATEquivFirst_SA_wrong_start", stack_disp(first(SB), "i"))]), + + /* Actually perform the test. */ + A:stack_eval_equiv_arg(SA, true, true, false, false), + AnswerNote:third(A), + FeedBack:stack_disp(second(A), "d"), + + ret:[true, first(A), AnswerNote, FeedBack], + return(ret) +)$ diff --git a/stack/2024060300/maxima/assessment.texi b/stack/2024060300/maxima/assessment.texi new file mode 100644 index 0000000..2f5fc37 --- /dev/null +++ b/stack/2024060300/maxima/assessment.texi @@ -0,0 +1,568 @@ +\input texinfo + +@c %**start of header (This is for running texinfo on a region.) +@setfilename assessment.info +@settitle An Assessment Package for Maxima + +@macro mybibitem{ref} +@item +@anchor{\ref\}[\ref\] +@end macro + + +@c %**end of header (This is for running texinfo on a region.) + +@ifinfo +@macro var {expr} +<\expr\> +@end macro +@end ifinfo + +@titlepage +@title An Assessment Package for Maxima +@subtitle Draft +@subtitle August 2011 +@author Chris Sangwin +@end titlepage + + +@node Top, Introduction to Assessment, (dir), (dir) +@top +@menu +* Introduction:: +@end menu + +@node Introduction to Assessment, , Top, Top + +@chapter The Assessment Package + +@section Introduction to Assessment + +This document describes an assessment package for the computer algebra system Maxima. + +Note, the assessment package is designed to be used with @code{simp:false}. Otherwise it will not always function correctly. + +A computer algebra system (CAS) is software for manipulating mathematical expressions symbolically. For example, we can expand out, or differentiate. Increasingly, CAS is being used to assess students' mathematical work automatically. +When doing this we seek to @emph{establish mathematical properties} of expressions, rather than performing calculations with them. For example, if @math{p(x)} is an expression provided by a student, we might try to establish @emph{``is @math{p(x)} an odd expression?''}. The prototype property is to establish if a student's answer @code{sa} is @emph{``equivalent to the teacher's answer @code{ta}''}. Establishing such properties is a key step in the assessment process. + +The STACK CAA system uses Maxima. +See @cite{Sangwin2006CASAlgebra}, @cite{WebALT2006}, @cite{Sangwin2007CAME}, @cite{SangwinTMA03}, +@cite{CervalPena2008}, @cite{Wild2009}, @cite{Lowe2010}, @cite{2010STACKReport}, @cite{Rasila2007}, @cite{Rasila2010}, @cite{Ruokokoski2009}, @cite{Harjula2008} and @cite{Nakamura2010}. +The assessment package comprises much of the code developed for STACK, but factored out into a more general package. In this way it can be used in other software projects, and others can more easily contribute to the development of other features. + +The design decisions made here are appropriate for @emph{elementary mathematics}. In particular, we are usually interested in working over the real numbers rather than the complex plane. + + +@node Simplification, , , Top +@section Representation of expressions and simplification + +Everything in Maxima is an @emph{expression}, including mathematical expressions, +objects, and programming constructs. An expression is either an atom, or +an operator together with its arguments. + +An atom is a symbol (a name), a string enclosed in quotation marks, an integer or floating point number. Note that rational numbers and complex numbers are not atoms. + +All other expressions have an @emph{operator} and list of @emph{arguments}. + +For the purposes of assessment we usually deal with expressions @emph{as provided by students}. In particular, we do not initially wish to manipulate them in any way. As a specific example, a student might enter an answer such as +@math{ {{3}\over{21}}x^2+0.5.} +We would certainly want to know that this is @emph{equivalent} to the correct answer @math{x^2/7+1/2}, but that it also contains (i) rational numbers not in lowest terms, and (ii) floating point numbers which are exact representations of rational numbers. Clearly there are a number of separate properties here, each of which needs an individual test. We do @emph{not} want the system to manipulate this expression into +@math{{{x^2}\over{7}}+0.5}, or even to rationalize it to @math{{{x^2}\over{7}}+{{1}\over{2}}}, before we have had a chance to establish these properties. + +Maxima is unusual in that @emph{all simplification} can be switched off using the command +@code{simp:false}. +The assessment package is designed to be used with @code{simp:false}. Otherwise it will not always function correctly. When this flag is set, even expressions such as @math{1+1} remain unchanged. Individual expressions can be evaluated with simplification using +@example +ev(ex,simp); +@end example + +The difficulty now, of course, is performing the @emph{correct} manipulations. This is not so simple. Internally, Maxima stores expressions as LISP trees. It is possible to obtain the internal data structure of the expression @code{ex} by using the command @code{?print(ex)}. Notice there is no space after the @code{?}, otherwise we would call for the helpfile. + +Notice the subtle differences when simplification is on or off, as illustrated by the following session. +@example +(%i1) p:x-1; +(%o1) x-1 + +(%i2) ?print(p)$ +((MPLUS SIMP) -1 $X) + +(%i3) simp:false$ + +(%i4) p:x-1; +(%o4) x-1 + +(%i5) ?print(p)$ +((MPLUS) $X ((MMINUS) 1)) +@end example + +In the first example we literally have @code{"+"(-1,x)}, while in the second we have @code{"+"(x,"-"(1))}. I.e., in the second we have a unary minus function applied to the number @math{1}. However, at the display level these expressions are indistinguishable. +The unary minus is particularly troublesome! + +Note that the flag @code{SIMP} in @code{((MPLUS SIMP) -1 $X)} indicates that the arguments have have already been simplified. + +@deffn {Function} safe_op (@var{ex}) +Note that applying @var{op} to an atom throws an error. Sometimes @var{op} returns a string, and sometimes a function name. (Compare @code{op(sin(x))} to @code{op(x+1)}). This function always returns a string. +If @var{ex} is an atom then we return the empty string @code{""}. +@end deffn + +@deffn {Function} coeff_list (@var{ex},@var{v}) +This function takes an expression @var{ex} and returns a list of coefficients of @var{v}. +@end deffn + + +@section Utility functions + +A predicate function returns either @code{true} or @code{false}. In Maxima, most predicate functions end with the letter @code{p}. + +@deffn {Function} element_listp (@var{ex},@var{l}) +Is @var{ex} an element of the list @var{l}? Note, ``sameness" is established with Maxima's @var{is} command. +@end deffn + +@deffn {Function} any_listp (@var{p},@var{l}) +Maps the predicate @var{p} to the list @var{l}, and then applies the Boolean connective @code{or}. +@end deffn + +@deffn {Function} all_listp (@var{p},@var{l}) +Maps the predicate @var{p} to the list @var{l}, and then applies the Boolean connective @code{and}. +@end deffn + +@deffn {Function} filter (@var{p},@var{l}) +Returns a list of those elements of @var{l} for which the predicate @var{p} is @code{true}. +@end deffn + +@deffn {Function} zip_with (@var{f},@var{a},@var{b}) +This takes a binary function @var{f} and two lists @var{a} and @var{b}. It returns the list +@example +[ f(a[1],b[1]), f(a[2],b[2]), ... ] +@end example +I.e. it @emph{zips} the two lists together with @var{f}. @code{zip_with} quietly gives up when one of the lists runs out of elements. For example, to implement the dot product of two lists @code{l1} and @code{l2} we could use +@example +apply("*",zip_with("+",l1,l2)); +@end example +@end deffn + +@deffn {Function} exdowncase (@var{ex}) +This function makes a substitution of all variables for their lower case equivalents. +Useful when wanting to do a specific case sensitivity +check, e.g. that @math{X^2=1} is @math{x^2=1}, without using @code{subst_equiv}. +Note that @code{exdowncase(X-x)} simplifies to zero, of course! +@end deffn + +@section Types of elementary object + +Maxima is a relatively weakly typed CAS. In particular, while Maxima tolerates polynomials with a mixture of floating point coefficients and integers, other CAS do not. In other CAS such as Axiom, see @cite{Jenks1992}, there is a much stronger sense of `type'. + +In the assessment world, we have the following types of objects +@enumerate +@item sets, +@item lists, +@item matrices, +@item equations and inequalities, +@item polynomials or other "expressions". +@end enumerate +This sense of type is useful, because it is nonsense to attempt to compare an equation, e.g. @math{y=mx+c} with an expression, e.g. @math{mx+c}. In assessment we need to establish which type of object we are dealing with before we can proceed. + +Maxima already has predicate functions such as @code{listp}, @code{matrixp} and @code{setp}. This package defines the rest. + +@deffn {Function} equationp (@var{ex}) +True if @code{op(ex)="="}@. Safe for atoms. +@end deffn + +@deffn {Function} inequalityp (@var{ex}) +True if @code{op(ex)}@ is some kind of inequality. Safe for atoms. +@end deffn + +@deffn {Function} expressionp (@var{ex}) +True if @code{op(ex)}@ is not a set, list, matrix, inequality or equation. Safe for atoms. +@end deffn + +Notice that in sets duplicates are removed. It is important to establish which notion of ``sameness'' is applied. In Maxima we currently have little control, other than @code{simp:true} and @code{simp:false}. + +Maxima already has a function @code{polynomialp(p,L)} which requires a list, @code{L}, of variable names. Hence, we define the following. + +@deffn {Function} polynomialpsimp (@var{p}) +This simply establishes if @var{p} is a polynomial in its own variables, i.e. +@example + polynomialpsimp(p):= polynomialp(p, listofvars(p))$ +@end example +@end deffn + +@section Numerical operations + +The assessment package defines the following functions for dealing with numbers. + +@deffn {Function} simp_numberp (@var{ex}) +@code{numberp(ex)} does not work when @code{simp:false}, since unary minus is an unevaluated function. Literally, input of @code{-1} is treated as @code{"-"(1)}. Hence, @code{simp_numberp} should be used instead. +@end deffn + +@deffn {Function} real_numberp (@var{ex}) +Surds and mathematical constants @math{\pi}, @math{e}, @math{\gamma} should also be considered as ``numbers'', even if from a formal point of view they are atomic CAS symbols, or operators and arguments, rather than numeric datatypes. Constants such as @math{\pi} are not considered numbers by Maxima's function @code{numberp}, so we need this separate predicate function to test for real numbers. +@end deffn + +@deffn {Function} decimalplaces (@var{x},@var{n}) +This function evaluates, i.e. rounds, @var{x} to @var{n} decimal places. Note that the number of decimal digits displayed by Maxima is controlled by @code{fpprintprec} which is currently limited to 16, so the displayed result of this calculation may not appear to be correct. +@end deffn + +@deffn {Function} significantfigures (@var{x},@var{n}) +This function evaluates, i.e. rounds, @var{x} into @var{n} significant figures. See @code{decimalplaces} for comments on numerical precision. +@end deffn + +@deffn {Function} scientific_notation (@var{ex}) +This writes the argument in the form @math{a\ 10^b}, where @math{0\leq a < 10}. +@end deffn + + +@deffn {Function} commonfaclist (@var{l}) +Returns the @code{gcd} of a list of numbers. +@end deffn + +@deffn {Function} factorlist (@var{ex}) +Returns a list of factors of @var{ex} without multiplicities. +@end deffn + +@deffn {Function} lowesttermsp (@var{ex}) +This returns @code{false} if @code{op(ex)} is division and the arguments are not coprime. +@end deffn + +@deffn {Function} list_expression_numbers (@var{ex}) +Create a list with all parts for which @code{numberp(ex)=true}, or which appear to be rational numbers. +@end deffn + +@deffn {Function} all_lowest_termsex (@var{ex}) +This is @code{true} if and only if all numbers appearing in the expression are written in lowest terms. +@end deffn + +@deffn {Function} anyfloatex (@var{ex}) +This is @code{true} if @var{ex} contains any floating point numbers. +@end deffn + +@section Inequalities + +The assessment package defines non-strict inequalities @code{>=} and @code {<=} as infix operators. + +@deffn {Function} ineqprepare (@var{ex}) +Reduces an inequality to either @code{? > 0} or @code{? >=0}. +@end deffn + + +@section Equivalence of expressions + +The assessment package defines the following senses in which two expressions are considered equivalent. +@enumerate +@item Same ``type'' of object. +@item Substitution equivalence. +@item Algebraic equivalence. +@item Equivalent up to associativity and commutativity of elementary algebraic operations. +@item Identical LISP trees. +@end enumerate +These tests return a boolean result, so strictly speaking could be predicate functions. However, they also return feedback which is suitable, and very useful, for computer aided assessment system. + +For example, the system might generate string such as ``@emph{Your answer should be a list, but is not.}" or ``@emph{Your inequality should not be strict! Your inequality appears to be backwards.}". Hence the answer tests are actually asymmetric when they might reasonably be expected to be symmertical/commutative in their arguments. The first argument is assumed to be the student's and the second argument the teacher's. In particular situations such feedback may be inappropriate or even irrelevant. It is much easier to generate this from the test and then subsequently suppress it than it would be to try to generate it again retrospectively with separate functions. + +Furthermore, the teacher is likely to want to compile statistics which include details of the logical mistake, regardless of the actual values used in the question. Hence, each test actually returns a list of three things, @code{[valid,value,feedback,note]}. + +The Boolean variable @code{valid} indicates if a test could be applied, or if @code{false} if for some reason occurred why this might be invalid. For example, a set cannot be compared with a list. The @code{value} is a Boolean of the outcome. The @code{feedback} is a language-independent string which can later be translated into actual feedback to the student. This may have displayed forms of expressions embedded within it. The @code{note} is used for statistical analysis. + +@subsection Same ``type'' of object + +This test establishes that expressions are of the same ``type''. +It works recursively over the entire expression, so a list of equations is different from a list of polynomials. +In order to provide feedback, it acts recursively on objects such as sets and lists to identify which members differ in type. +Matrices are checked for size and matrix elements are examined individually. + +@subsection Substitution equivalence + +Consider a situation where a student types in @math{X^2+1} rather than @math{x^2+1}. In this case we could establish algebraic equivalence by using case insensitivity. However, given two expressions @var{ex1} and @var{ex2}, we could also seek a substitution of the variables of @var{ex2} into @var{ex1} which renders @var{ex1} algebraically equivalent to @var{ex2}. +If @code{ex1=X^2+1} and @code{ex2=x^2+1} then for our example, the required substitution is @code{X=x}. +This test is surprisingly useful, especially in establishing whether the student has used the wrong variable name beyond case insensitivity. + +@deffn {Function} subst_equiv (@var{ex1},@var{ex2}) +This function establishes if there exists a substitution of the variables of @var{ex2} into @var{ex1} which renders @var{ex1} algebraically equivalent to @var{ex2}. + If such a substitution exists the function returns it in a form so that + @code{ex2 = ev(ex1, subst_equiv(ex1,ex2))}. + If no such permutation exists it returns the empty list @code{[]}. + This algorithm is of factorial order in the number of variables. + If there are more than 4 variables then the system returns @code{false} to prevent instability. +@end deffn + + +@subsection Algebraic equivalence + +This is the prototype test. The student's answer is assigned internally to a CAS variable @var{sa} and the teacher's expression to @var{ta}. +Essentially we evaluate the following pseudo-code +@example + if simplify(sa-ta)=0 then true else false. +@end example + +There are theoretical limits on the extent to which this test works. +See @cite{Richardson1966}, @cite{Caviness1970} and @cite{Moses1971}. +In practice, for learning and teaching, this test works very well indeed on the limited range of expressions used. +As @cite{Fenichel1966} comments @emph{``recursive undecidability can be a remote and unthreatening form of hopelessness''}. + +@deffn {Function} algebraic_equivalence (@var{ex1},@var{ex2}) +This function tests for algebraic equivalence of @var{ex1} and @var{ex2} by attempting to establish that the difference is zero. This function expects @var{ex1} and @var{ex2} to be expressions, but no checking is done. +@end deffn + +@subsection Associativity and Commutativity + +This test seeks to establish whether two expressions are the same when the basic arithmetic operations of addition and multiplication are assumed to be nouns but are commutative and associative. Hence, @math{2x+y=y+2x} but @math{x+x+y\neq 2x+y}. The real difficulties here are the inverse operations, and in particular the unary minus. + +The first step is to replace all arithmetic operations by a pseudo-noun form as follows. + +@deffn {Function} nounadd (@var{[ex]}) +This is a commutative, associative, nary operator. Normal addition is replaced by this operator when we are testing for equivalence up to associativity and commutativity. +@end deffn + +@deffn {Function} nounmul (@var{[ex]}) +This is a commutative, associative, nary operator. Normal multiplication is replaced by this operator when we are testing for equivalence up to associativity and commutativity. +@end deffn + +@deffn {Function} nounpow (@var{a},@var{b}) +This is a binary infix operator. Normal exponentiation is replaced by this operator when we are testing for equivalence up to associativity and commutativity. +@end deffn + +@deffn {Function} nounsub (@var{ex}) +This is a prefix operator. This is to match unary minus when we are testing for equivalence up to associativity and commutativity. However, in practice unary minus, @code{"-"(ex)}, is replaced by @code{UNARY_MINUS nounmul ex} so that it correctly commutes with multiplication. +@end deffn + +We need functions which will transform expressions between these forms. + +@deffn {Function} noun_arith (@var{ex}) +All operations are replaced with their noun forms. Note that unary minus function, @code{"-"(ex)} is replaced by @code{UNARY_MINUS nounmul ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 nounmul (UNARY_RECIP ex2)}. +@end deffn + +@deffn {Function} verb_arith (@var{ex}) +All noun operations are replaced with their verb forms. +@end deffn + +@deffn {Function} equals_commute_associate (@var{ex1},@var{ex2}) +Returns @code{true} if and only if @var{ex1} and @var{ex2} are equal up to associativity and commutativity of the elementary algebraic operations. +@end deffn + +Notice, that these functions would enable us to define specific rule-based transformations such as @math{-(-x)\rightarrow x}, but at this stage we have not done this. + + +@subsection Parse tree equality + +This ensures that the two expressions have the same representation in the data structure of Maxima. +This is the strictest notion of all and in practice it is surprisingly rarely helpful. For example, the expressions @math{x+y} and @math{y+x} have different representations as trees, but in few situations would a teacher accept one but not the other. + +There is no need for a function. With @code{simp:false} we simply use the code +@example + if ex1=ex2 then true else false +@end example + +@section Equivalence of equations + +Single equations and inequalities are transformed into the forms @math{p=0}, @math{p>0} and @math{p\geq 0} and are then compared. + +Systems of polynomial equations are dealt with using Grobner basis techniques. +See @cite{Sangwin2010IGI} for more details. + +@section Analysis + +The assessment package has predicates which establish that an expression is continuous or differentiable at a particular point. There are, of course, theoretical limits on the extent to which these functions can possibly work and also practical limitations of Maxima's current implementation of the @code{limit} function. + +@deffn {Function} continuousp (@var{ex},@var{v},@var{p}) +Establishes is @var{ex} is continuous in the variable @var{v} at the point @var{p}. +@end deffn + + +@deffn {Function} diffp (@var{ex},@var{v},@var{p},@var{n}) +Establishes is @var{ex} is @var{n}-times differentiable in the variable @var{v} at the point @var{p}. +The argument @var{n} is optional. +@end deffn + +There are also specific tests for assessment questions in calculus, e.g. differentiation and integration, as constants of integration can be difficult to spot reliably. + +@section Algebraic forms + +The assessment package has a number of tests for particular algebraic forms. + +@subsection Expanded @emph{vs} Factored + +Checking whether an expression is factored is significantly different from comparing an expression @var{ex} with the result of @code{factor(ex)}. +Consider the following forms of @math{x^2-4x+4} + +@math{(x-2)(x-2)}, @math{(x-2)^2}, @math{(2-x)^2}, @math{4\left(1-{{x}\over{2}}\right)^2}. + +One might argue that each of these is factored, if not fully ``simplified''. + +Such a test seeks to establish that the expression is a product of powers of distinct irreducible factors. @cite{Sangwin2009CalculumusII} identified the following meanings. +For example, consider @math{x^8+16x^4+48}. +@enumerate +@item Any non-trivial factorization, e.g. @math{(x^4+4)(x^4+12)}. +@item A factorization into irreducible factors over the integers, @* +i.e. @math{(x^2+2x+x)(x^2-2x+2)(x^4+12)}. +@item A factorization into terms irreducible over the reals, @* + i.e. @math{(x^2+2x+x)(x^2-2x+2)(x^2+2\root 4\of{3}x+2\root 4\of{3})(x^2-2\root 4\of{3}x+2\root 4\of{3})}. +@item A factorization into irreducible polynomials over the Gaussian integers, with @math{i} allowed,@* +i.e. @math{(x+1+i)(x+1-i)(x-1+i)(x-1-i)(x^4+12)}. +@item A factorization over the complex numbers, where the factor @math{(x^4+12)} would also be split into the four terms @math{x\pm\root 4\of{3}(1\pm i)}. +@end enumerate +In elementary teaching, meaning 4. is unlikely to occur. Indeed, we might take this example to represent factoring over any extension field of the rational numbers. We normally seek to establish that the factors are irreducible over the integers (which is equivalent to irreducibility over the rational numbers) or the reals. But, unlike a canonical form, we are not particularly interested in the order of the terms in this product, or the order of summands inside these terms. Strictly speaking, in establishing that an expression is in factored form, we might not even care whether the terms in the product are fully simplified, as long as they are irreducible. + +There are some delicate cases such as: @math{(2-x)(3-x)} vs @math{(x-2)(x-3)} and @math{(1-x)^2} vs @math{(x-1)^2}. + +Establishing that an expression, @var{ex}, is expanded is much more straightforward. Essentially, we compare @var{ex} with @code{expand(ex)} up to commutativity and associativity of the algebraic operations. + +@deffn {Function} factorp (@var{ex}) +Returns @code{true} if @var{ex} equals @code{factor(ex)}. Note, some wrinkles with unary minus etc. are ironed out quietly with this function. +@end deffn + +@deffn {Function} expoandp (@var{ex}) +Returns @code{true} if @var{ex} equals @code{expand(ex)}. +@end deffn + +@subsection Rational expression @emph{vs} Partial fraction + +Testing for a rational expression is relatively simple. We do need to establish the denominator and numerator have no common factors, otherwise feedback is available. + +Partial fractions form is more difficult to recognize. Just as with the factor test this is significantly different from checking equivalence with the result of the @code{partfrac} function. There are also subtleties here, as illustrated by +@math{{{1}\over{n+1}}+{{1}\over{1-n}} = {{1}\over{n+1}}-{{1}\over{n-1}}} +and +@math{{{1}\over{4n-2}}-{{1}\over{4n+2}}={{n}\over{2n-1}}-{{n+1}\over{2n+1}}.} + + +@section Buggy rules + +In order to establish that the student has done something particular but wrong, it is useful for us to be able to apply @emph{wrong} or @emph{buggy} rules to expressions. A typical example would be to expand out powers in the wrong way, e.g. @math{(x+y)^2=x^2+y^2}. The following function does this! + +@deffn {Function} buggy_pow (@var{ex}) +Implements the ``buggy'' linearity rule for exponentiation, i.e. @math{(a+b)^n \rightarrow a^n+b^n}. This is useful if we want to compare a student's answer to the result of having done something wrong. +@end deffn + +The following is not always a ``buggy rule'', when used for example in connection with Farey sequences, but it is included here as in assessment this function is useful for checking a common mistake when adding fractions. +@deffn {Function} mediant (@var{ex1},@var{ex2}) +The mediant of two fractions @math{{p_1}\over {q_1}} and @math{{p_2}\over{q_2}} is @math{{p_1+p_2}\over {q_1+q_2}}. Note that both @code{denom} and @code{num} work on non-rational expressions, assuming the expression to be ``over one'' by implication. Hence @code{mediant} will also assume the denominator is also one in such cases. +@end deffn + +There is scope for further examples of such rules. +See, for example, @cite{Sleeman1982} for more details. + + +@section Future plans + +Better support is needed for the following features: + +@enumerate +@item Dealing with systems of inequalities, and intervals. + Canonical form for systems of inequalities. Note that Maxima already can represent expressions such as @code{x>1 and x<4}, and the library @code{to_poly_solver} can solve systems such as the following + @example + (%i1) load("to_poly_solver")$ + (%i2) to_poly_solve((x-1)*(x-4)<0,x); + (%o2) %union([1. */ + +/******************************************************************/ +/* Functions for extracting data from matching problems */ +/* in STACK to a format that can be assessed by the author. */ +/* Should be used when providing model answers and writing */ +/* PRTs for matching problems using the `parsons` block. */ +/* */ +/* Salvatore Mercuri, */ +/* V1.0 May 2024 */ +/* */ +/******************************************************************/ + +/* To use these functions load the library via one of the following +two commands inside `Question variables`. + +stack_include("https://raw.githubusercontent.com/maths/moodle-qtype_stack/proof-builder/stack/maxima/contrib/matchlib.mac"); +stack_include("contribl://matchlib.mac"); +*/ + +/******************************************************************/ +/* */ +/* Assessment helper functions */ +/* */ +/******************************************************************/ + +/* + * Use this to extract an answer from the student's input of desirable format + * for assessing. + * + * Take the JSON from STACK Parson's block when using `columns` and/or + * `rows` header parameter, and returns a two-dimensional array corresponding to + * the answer keys in the JSON. + * + * If only `columns` has been specified in the `parsons` block, then use + * this function as `match_interpret(ans1)`. This will return an + * array of shape `(columns, ?)` if, where `?` represents variable dimension. + * + * If both `rows` and `columns` have been specified in the `parson` block, then + * use this function as `match_interpret(ans1, true)`. This will + * return an array of shape `(columns, rows)`. + */ +match_interpret(st, [rows]) := block([js, arr], + js: stackjson_parse(st), + arr: stackmap_get(js, "used"), + if rows=[] then arr:map(lambda([keys], first(keys)), arr) + else arr:map(lambda([keys], map(lambda([k], first(k)), keys)), arr), + return(arr) +); + +/* + * Auxiliary function. + * + * Takes a list of matched keys and returns the keys not used. + * Needed to create a "teacher's answer" in JSON format, including unused text. + */ +match_keys_used_unused(ans, steps) := block([tkeys], + tkeys:map(first, steps), + return([ans, listdifference(tkeys, ev(unique(flatten(ans)), simp))]) +); + +/* + * Use this to transform the teacher's answer into the shape expected by the Parson's block. + * Returns an array of `[answer_keys, unused_keys]`, where `unused_keys` is always a flat + * list of keys that are in the question but not inside `ans`. + * + * If only `columns` has been specified in the `parsons` block, then use + * this function as `match_reshape(ans1)`. This will return `answer_keys` as an + * array of shape `(columns, 1, ?)` if, where `?` represents variable dimension. + * + * If both `rows` and `columns` have been specified in the `parson` block, then + * use this function as `match_interpret(ans1, true)`. This will + * return `answer_keys` as an array of shape `(columns, rows, 1)`. + */ +match_reshape(ans, steps, [rows]) := block([tkeys, akeys], + tkeys: match_keys_used_unused(ans, steps), + if rows=[] then akeys: map(lambda([keys], [keys]), first(tkeys)) + else akeys:map(lambda([keys], map(lambda([k], [k]), keys)), first(tkeys)), + return([akeys, second(tkeys)]) +); + +/* + * Use this to transform the teacher's answer into the JSON format expected by the `Model answer` field. + * + * If only `columns` has been specified in the `parsons` block, then use + * this function as `match_correct(ans1)`. + * + * If both `rows` and `columns` have been specified in the `parson` block, then + * use this function as `match_correct(ans1, true)`. + */ +match_correct(ans, steps, [rows]) := block([akeys, ukeys], + if rows=[] then [akeys, ukeys]: match_reshape(ans, steps) + else [akeys, ukeys]: match_reshape(ans, steps, rows), + sconcat("{\"used\":", stackjson_stringify(akeys), ", \"available\":", stackjson_stringify(ukeys), "}") +); + +/* + * Use this to turn a row-grouped answer into a column-grouped answer and vice-versa. + * + * Note that model answers for matching problems in STACK should always be written by grouping + * the columns, that is they should be a two-dimensional array of shape `(columns, rows)`. Authors + * may prefer to use the row-grouped answer in PRTs. This function will move between them. + */ +match_transpose(ans) := block( + return(args(transpose(apply(matrix, ans)))) +); + +/* + * Use this on both the model answer and the student input + * when you do not care about the order within a column. + * + * It will turn `[[a, b], [c, d], [e, f]]` into `[{a, b}, {c, d}, {e, f}]`. + */ +match_column_set(ans) := block( + return(map(lambda([col], apply(set, col)), ans)) +); + +/* + * Use this on both the model answer and the student input + * when you do not care about the order within a row. + * + * It will turn `[[a, b], [c, d], [e, f]]` into `[{a, c, e}, {b, d, f}]`. + */ +match_row_set(ans) := block( + return(match_column_set(match_transpose(ans))) +); + +/* + * Use this on both the model answer and the student input + * when you do not care about the order between columns. + * + * It will turn `[[a, b], [c, d], [e, f]]` into `{[a, b], [c, d], [e, f]}`. + */ +match_set_column(ans) := block( + return(apply(set, ans)) +); + +/* + * Use this on both the model answer and the student input + * when you do not care about the order between rows. + * + * It will turn `[[a, b], [c, d], [e, f]]` into `{[a, c, e], [b, d, f]}`. + */ +match_set_row(ans) := block( + return(match_set_column(match_transpose(ans))) +); + diff --git a/stack/2024060300/maxima/contrib/prooflib.mac b/stack/2024060300/maxima/contrib/prooflib.mac new file mode 100644 index 0000000..e48f225 --- /dev/null +++ b/stack/2024060300/maxima/contrib/prooflib.mac @@ -0,0 +1,444 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/******************************************************************/ +/* Functions for representing, typesetting and assessing proof. */ +/* Mostly for use with Parsons problems. */ +/* */ +/* Chris Sangwin, */ +/* V1.0 Sept 2023 */ +/* */ +/******************************************************************/ + +/* An example of how to use these functions. + +stack_include("https://raw.githubusercontent.com/maths/moodle-qtype_stack/proof-builder/stack/maxima/contrib/prooflib.mac"); +stack_include("https://raw.githubusercontent.com/maths/moodle-qtype_stack/proof-builder/stack/maxima/contrib/proofsamples/odd-squaredodd.mac"); + +stack_include("contribl://prooflib.mac"); +stack_include("contribl://proofsamples/odd-squaredodd.mac"); + +tap:proof_display(proof_ans, proof_steps); + +{@thm@} +{@tap@} +*/ + +/******************************************************************/ +/* Types of proof. */ +/* */ +/* proof() - general, unspecified proof */ +/* proof_c() - general proof, with commutative arguments */ +/* proof_opt() - proof_opt() */ +/* */ +/* proof_iff() - if any only if */ +/* proof_cases() - proof by exhaustive cases, the first element */ +/* is assumed to justify the cases. */ +/* proof_goal() - proof by establishing a goal, the last element */ +/* is assumed to justify by the previous cases. */ +/* proof_ind() - proof by induction */ +/* */ +/******************************************************************/ + +/* General proof functions */ +/* Please update Proof/Proof_CAS_library.md with new types. */ + +/* Note, "proof" is assumed to come first in this list, as we use "rest" below for other types. */ +proof_types:[proof, proof_c, proof_opt, proof_iff, proof_cases, proof_goal, proof_ind]; + +proofp(ex) := block( + if atom(ex) then true, + if elementp(op(ex), setify(proof_types)) then return(true), + return(false) +); + +proof_validatep(ex) := block( + if atom(ex) then return(true), + if op(ex) = proof_opt then + if not(is(length(args(ex)) = 1)) then return(false) + else return(all_listp(proof_validatep, args(ex))), + if op(ex) = proof_iff then + if not(is(length(args(ex)) = 2)) then return(false) + else return(all_listp(proof_validatep, args(ex))), + if op(ex) = proof_ind then + if not(is(length(args(ex)) = 4)) then return(false) + else return(all_listp(proof_validatep, args(ex))), + /* Validate all remaning proof types. */ + if proofp(ex) then return(all_listp(proof_validatep, args(ex))), + return(false) +); + +/* Is this a type of proof which can reorder its arguments? */ +proof_commutep(ex):=block( + if atom(ex) then false, + if is(op(ex)=proof_c) then return(true), + if is(op(ex)=proof_iff) then return(true), + return(false) +); + +/* Takes a proof tree and flattens this to a list. */ +proof_flatten(ex) := apply(proof, flatten(ev(ex, map(lambda([ex2], ex2="["), proof_types)))); + +/* + * Create a normalised proof tree. + * To establish equivalence of proof trees we compare the normalised form. + * This basically sorts and "simplifies" its arguments. + * We also remove the proof_opt tag. +*/ +proof_normal(ex) := block( + if atom(ex) then return(ex), + if op(ex) = proof_opt then return(first(args(ex))), + /* Only sort arguments to types of proof which commute. */ + if proof_commutep(ex) then return(apply(op(ex), sort(map(proof_normal, args(ex))))), + /* Some proof types have subsets of arguments which commute. */ + if op(ex) = proof_cases then return(apply(proof_cases, append([first(args(ex))], sort(map(proof_normal, rest(args(ex))))))), + if op(ex) = proof_goal then return(apply(proof_goal, append(sort(map(proof_normal, reverse(rest(reverse(args(ex)))))), [first(reverse(args(ex)))]))), + if op(ex) = proof_ind then return(apply(proof_ind,append([first(args(ex))], sort([proof_normal(second(args(ex))), proof_normal(third(args(ex)))]), [fourth(args(ex))]))), + return(apply(op(ex), map(proof_normal, args(ex)))) +); + +/******************************************************************/ +/* */ +/* Assessment functions */ +/* */ +/******************************************************************/ + +/* Create a list of all proof trees which are alternatives to this. + Clearly this is a potentially exponential algorithm, so use with care! +*/ +proof_alternatives(ex):=block([p1,p2], + p2:proof_one_alternatives(ex), + do (p1:p2, p2:proof_one_distrib(p1), if is(p1=p2) then return(map(proof_remove_nullproof, proof_ensure_list(p2)))) +); + +proof_one_alternatives(pr) := block( + if atom(pr) then return(pr), + if proof_commutep(pr) then return(apply(pf_one, map(lambda([ex], apply(op(pr), map(proof_one_alternatives, ex))), listify(permutations(args(pr)))))), + /* In a proof by exhaustive cases the first element is fixed. */ + if op(pr)=proof_opt then return(pf_one(first(pr), nullproof)), + /* In a proof by exhaustive cases the first element is fixed. */ + if op(pr)=proof_cases then return(apply(pf_one, map(lambda([ex], apply(op(pr), append([first(args(pr))], map(proof_one_alternatives, ex)))), listify(permutations(rest(args(pr))))))), + /* In a proof establishing a goal the last element is fixed. */ + if op(pr)=proof_goal then return(apply(pf_one, map(lambda([ex], apply(op(pr), append(map(proof_one_alternatives, ex), [first(reverse(args(pr)))]))), + listify(permutations(rest(reverse(args(pr)))))))), + /* In a proof by induction cases the first element and last elents are fixed. */ + if op(pr) = proof_ind then return(apply(pf_one, map(lambda([ex], apply(op(pr), append([first(args(pr))], + map(proof_one_alternatives, ex), [fourth(args(pr))]))), listify(permutations([second(args(pr)), third(args(pr))]))))), + apply(op(pr), map(proof_one_alternatives, args(pr))) +); + +proof_one_distribp(ex):= not(atom(ex)) and is(op(ex)=pf_one); + +proof_one_distrib(ex):= block([_a,_i,_l], + if atom(ex) then return(ex), + if freeof(pf_one, ex) then return(ex), + /* If pf_one has worked its way to the top we return the list of options. */ + if is(op(ex)=pf_one) then return(args(ex)), + if (listp(ex)) then return(flatten(map(proof_one_distrib, ex))), + /* Pull out first argument to have pf_one */ + _i:sublist_indices(args(ex), proof_one_distribp), + /* If none of the arguments need distribution, then go one level down. */ + if emptyp(_i) then return(apply(op(ex), map(proof_one_distrib, args(ex)))), + _i:first(_i), + _a:args(part(args(ex),_i)), + _l:ev(makelist(k,k,1,length(_a)),simp), + /* This list is not free of pf_one, so we take the first. */ + apply(pf_one, map(lambda([ex2], block([_aa], _aa:copy(args(ex)), _aa[_i]:_a[ex2], return(apply(op(ex),_aa)))), _l)) +); + +proof_ensure_list(ex):= if listp(ex) then ex else [ex]; + +proof_remove_nullproof(ex):= block( + if atom(ex) then return(ex), + if freeof(nullproof, ex) then return(ex), + apply(op(ex), map(proof_remove_nullproof, sublist(args(ex), lambda([ex2], not(is(ex2=nullproof)))))) +); + +/******************************************************************/ +/* */ +/* STACK Parson's block functions */ +/* */ +/******************************************************************/ + +/* + * Take the JSON from STACK Parson's block and return a proof function. + */ +proof_parsons_interpret(st) := block([pf], + pf:stackjson_parse(st), + pf:apply(proof, first(first(stackmap_get(pf, "used")))) +); +s_test_case(proof_parsons_interpret("{\"used\":[[[\"0\",\"3\",\"5\"]]],\"available\":[\"1\",\"2\",\"4\",\"6\",\"7\"]}"), proof("0","3","5")); + +/* + * Takes a proof, and proof steps list and returns the keys not used in the proof_steps. + * Needed to create a "teacher's answer" in JSON block, including unused text. +*/ +proof_parsons_keys_used_unused(proof_ans, proof_steps) := block([tkeys, skeys], + tkeys:map(first, proof_steps), + skeys:ev(proof_ans, map(lambda([ex], ex="["), proof_types), simp), + /* TO-DO: update this when we deal with trees (and have examples) */ + skeys:flatten(skeys), + return([skeys, listdifference(tkeys, ev(unique(skeys), simp))]) +); + +/* Construct the "used" and "available" keys when the teacher's answer is used. */ +proof_parsons_key_json(proof_ans, proof_steps) := block([pkeys], + /* Ensure all keys are string keys. */ + if not(emptyp(proof_steps)) then proof_ans:proof_keys_sub(proof_ans, proof_steps), + pkeys:proof_parsons_keys_used_unused(proof_ans, proof_steps), + sconcat("{\"used\":", stackjson_stringify([[first(pkeys)]]), ", \"available\":", stackjson_stringify(second(pkeys)), "}") +); + +/******************************************************************/ +/* */ +/* Display functions */ +/* */ +/******************************************************************/ + +/* + * Return the step "k" from the proof "pf". + */ +proof_getstep(k, pf) := block([keylist], + if integerp(k) then return(second(pf[k])), + keylist:sublist(pf, lambda([ex], is(first(ex)=k))), + if not(emptyp(keylist)) then return(second(first(keylist))), + /* If the string is not in the pf list, then just return it unchanged. + Teachers can use this to adapt proofs which use some of the steps. + */ + k +); + +/* + * This function replaces integers and keys with the literal strings from the proof. + */ +proof_disp_replacesteps(ex, proof_steps) := block( + if integerp(ex) or stringp(ex) then return(proof_getstep(ex, proof_steps)), + if atom(ex) then return(sconcat("Error: the following atom does not index a step: ", string(ex))), + /* Flatten any optional steps now. */ + if is(op(ex)=proof_opt) then return(proof_disp_replacesteps(first(args(ex)), proof_steps)), + apply(op(ex), map(lambda([ex2], proof_disp_replacesteps(ex2, proof_steps)), args(ex))) +); + +/** + * Take a proof "ex" and a list "pf" of [key, step] pairs and translate this into a proof tree with + * the keys replaced by corresponding strings. + */ +proof_keys_sub(ex, proof_steps):= block( + if integerp(ex) then return(first(proof_steps[ex])), + if stringp(ex) then return(ex), + apply(op(ex), map(lambda([ex2], proof_keys_sub(ex2, proof_steps)), args(ex))) +); + +/** + * Take a proof "ex" and a list "pf" of [key, step] pairs and translate this into a proof tree with + * the keys replaced by corresponding integers. + */ +proof_keys_int(ex, proof_steps):= block( + if integerp(ex) then return(ex), + if stringp(ex) then return(first(sublist_indices(proof_steps, lambda([ex2], is(ex=first(ex2)))))), + apply(op(ex), map(lambda([ex2], proof_keys_int(ex2, proof_steps)), args(ex))) +); + +/** + * Replace displayed LaTeX mathematics delimiters with inline. + */ +proof_inline_maths(st) := ssubst("\\)", "\\]", ssubst("\\(", "\\[", st)); + +/* + * Prune out any narrative from the proof steps: used to display a proof without narrative. +*/ +proof_line_prune(pfs) := [first(pfs), second(pfs)]; +proof_steps_prune(proof_steps) := map(proof_line_prune, proof_steps); + +/* + * Return the step "k" from the proof "pf" wrapped in html divs, and with any narrative. + */ +proof_getstep_html(k, pf) := block([keylist], + if integerp(k) then return(proof_line_html(pf[k])), + keylist:sublist(pf, lambda([ex], is(first(ex)=k))), + if not(emptyp(keylist)) then return(proof_line_html(first(keylist))), + /* If the string is not in the pf list, then just return it unchanged. + Teachers can use this to adapt proofs which use some of the steps. + */ + k +); + +/* + Wrap lines in html
tags, and add narrative if it exists. + pfs is a line from the proof_steps array. +*/ +proof_line_html(pfs) := block([st], + st:"", + if is(length(pfs)>2) then + st:proof_comment_disp(third(pfs)), + proof_line_disp(second(pfs), st) +); + +/* + * This function replaces integers and keys with the html-wrapped strings from the proof. + */ +proof_disp_replacesteps_html(ex, proof_steps) := block( + if integerp(ex) or stringp(ex) then return(proof_getstep_html(ex, proof_steps)), + if atom(ex) then return(sconcat("Error: the following atom does not index a step: ", string(ex))), + /* Flatten any optional steps now. */ + if is(op(ex)=proof_opt) then return(proof_disp_replacesteps(first(args(ex)), proof_steps)), + apply(op(ex), map(lambda([ex2], proof_disp_replacesteps_html(ex2, proof_steps)), args(ex))) +); + +/** + * Take a proof, and any proof steps and display them using proof CSS. + */ +proof_display(proof_ans, proof_steps) := ev(proof_disp_replacesteps_html(proof_ans, proof_steps), map(lambda([ex], ex=dispproof), proof_types)); + +/* Make use of the existing styles. See https://docs.stack-assessment.org/en/Topics/Proof/ */ +dispproof([ex]) := block([ex1], + apply(sconcat, flatten(append(["
"], [simplode(ex)], ["
"]))) +); + +/** + * Take a proof, and any proof steps and display them using paragraphs. + */ +proof_display_para(proof_ans, proof_steps) := ev(proof_disp_replacesteps(proof_ans, proof_steps), map(lambda([ex], ex=dispproof_para), proof_types)); + +/* Flatten to a paragraph. */ +dispproof_para([ex]) := block([ex1], + apply(sconcat, flatten(append(["

"], [simplode(ex, " ")], ["

"]))) +); + +/* Use the summary/details HTML tag. +dispproof([ex]) := block([ex1], + apply(sconcat, flatten(append(["
"], [simplode(ex, "
")], ["
"]))) +); +*/ + +/******************************************************************/ +/* */ +/* Assessment and feedback functions */ +/* */ +/******************************************************************/ + +/* ********************************** */ +/* Levenshtein distance */ +/* ********************************** */ + +/* + Levenshtein distance with swap tracking + s,t: lists to compare + Returns integer d, the Levensthein distance between s and t. + Returns the process of getting from s to t. + Original author Achim Eichhorn Achim.Eichhorn(at)hs-esslingen.de modified by Chris Sangwin to track process. +*/ +proof_damerau_levenstein(s, t) := block([c, m, n, XY, XYaction, i, j, d, temp, L, lm, li, dl_tags, simp], + simp:true, + if(s=t) then return([0,[]]), /* Equal strings result in 0, nothing to do. */ + m:length(s), + n:length(t), + XY: matrix(makelist(i,i,0,n), makelist(0,i,1,n+1)), + XYaction: matrix(makelist(makelist(dl_add(t[k]),k,1,i),i,0,n), makelist([],i,1,n+1)), + for i:1 thru m do ( + XY[2][1]:i, + XYaction[2][1]:makelist(dl_delete(s[k]),k,1,i), + for j:1 thru n do( + c:if is(s[i]=t[j]) then 0 else 1, + L:[XY[2][j]+1, /* Insertion */ + XY[1][j+1]+1, /* Deletion */ + XY[1][j]+c], /* Substitution */ + /* Add in the swap rule. */ + /* The swapping costs nothing, but the cost comes from the subsequent dl_subs, which we filter out. */ + if is(i ", ex); +dl_ok_disp(ex) := ""; +dl_delete_disp(ex) := ""; +dl_swap_disp([ex]) := ""; +dl_swap_follow_disp(ex) := ""; +dl_subs_disp([ex]) := sconcat(" ", + " ", second(ex)); + +proof_line_disp(ex1, ex2):= sconcat("
", ex1, ex2, "
"); +proof_comment_disp(ex):= sconcat("
", ex, "
"); +proof_column_disp(ex):= sconcat("
", ex, "
"); +proof_column_disp2(ex):= sconcat("
", ex, "
"); + +dl_disp(ex):=ev(ex, dl_empty=dl_empty_disp, dl_ok=dl_ok_disp, dl_delete=dl_delete_disp, dl_add=dl_add_disp, + dl_swap=dl_swap_disp, dl_swap_follow=dl_swap_follow_disp, dl_subs=dl_subs_disp); + +proof_assessment_display(saa, pf) := block([st, k], + /* An empty list is returned when we have a correct proof. */ + if emptyp(saa) then return(""), + saa:proof_disp_replacesteps(saa, pf), + /* sal is now a list of strings from the proof. */ + st:[], + for k:1 thru length(saa) do block([s0,s1], + s0:saa[k], + s1:first(s0), + if is(op(s0)=dl_add) then + st:append(st, [[dl_empty(null), s0]]) + else + st:append(st, [[s1, s0]]) + ), + /* Turn the st list of lists into a string to display. */ + st:dl_disp(st), + for k:1 thru length(saa) do block( + st[k]:proof_line_disp(proof_column_disp(first(st[k])), proof_column_disp(second(st[k]))) + ), + st:apply(sconcat, st), + sconcat("
", st, "
") +); + diff --git a/stack/2024060300/maxima/contrib/prooflib_test.mac b/stack/2024060300/maxima/contrib/prooflib_test.mac new file mode 100644 index 0000000..cc5c1e7 --- /dev/null +++ b/stack/2024060300/maxima/contrib/prooflib_test.mac @@ -0,0 +1,73 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/******************************************************************/ +/* Functions for representing, typesetting and assessing proof. */ +/* Mostly for use with Parsons problems. */ +/* */ +/* Test cases. */ +/* */ +/* Chris Sangwin, */ +/* V1.0 May 2024 */ +/* */ +/******************************************************************/ + +s_test_case(proofp(proof(1,2,3)), true); +s_test_case(proofp(proof_iff(1,2)), true); +s_test_case(proofp(sin(x)), false); + +s_test_case(proof_validatep(proof(1,2,3)), true); +s_test_case(proof_validatep(proof(1,2,proof(4,5,6))), true); +s_test_case(proof_validatep(proof(1,2,proof_iff(4,5))), true); +/* proof_opt must have exactly one sub-proof. */ +s_test_case(proof_validatep(proof(1,2,proof_opt(4,5))), false); +/* proof_iff must have exactly two sub-proofs. */ +s_test_case(proof_validatep(proof(1,2,proof_iff(4))), false); +s_test_case(proof_validatep(proof(1,2,proof_iff(4,5,6))), false); +/* proof_ind must have exactly four sub-proofs. */ +s_test_case(proof_validatep(proof_ind(1,proof(2,3),proof(4,5),6)), true); +s_test_case(proof_validatep(proof_ind(1,proof(2,3),proof(4,5))), false); +s_test_case(proof_validatep(proof(1,proof_opt(2),proof_iff(4,5))), true); + +s_test_case(proof_flatten(proof_iff(proof(A,B),proof(C))), proof(A,B,C)); +s_test_case(proof_flatten(proof_c(proof(A,proof(B,C)),proof(D))), proof(A,B,C,D)); + +s_test_case(proof_normal(proof_c(B,A,D,C)), proof_c(A,B,C,D)); +s_test_case(proof_normal(proof_iff(B,A)), proof_iff(A,B)); +s_test_case(proof_normal(proof_ind(D,C,B,A)), proof_ind(D,B,C,A)); +s_test_case(proof_normal(proof_cases(D,C,B,A)), proof_cases(D,A,B,C)); +s_test_case(proof_normal(proof_goal(D,C,B,A)), proof_goal(B,C,D,A)); +s_test_case(proof_normal(proof_iff(proof_c(proof_opt(C),A), B)), proof_iff(proof_c(A,C),B)); + +s_test_case(proof_alternatives(proof(A,B,C,D)), [proof(A,B,C,D)]); +s_test_case(proof_alternatives(proof_c(A,B)), [proof_c(A,B),proof_c(B,A)]); +s_test_case(proof_alternatives(proof_iff(A,B)), [proof_iff(A,B),proof_iff(B,A)]); +s_test_case(proof_alternatives(proof_ind(A,B,C,D)), [proof_ind(A,B,C,D),proof_ind(A,C,B,D)]); +s_test_case(proof_alternatives(proof_cases(A,B,C)), [proof_cases(A,B,C),proof_cases(A,C,B)]); +s_test_case(proof_alternatives(proof_goal(A,B,C)), [proof_goal(A,B,C),proof_goal(B,A,C)]); +s_test_case(proof_alternatives(proof_iff(proof(proof_opt(A), B),C)), [proof_iff(proof(A,B),C),proof_iff(proof(B),C),proof_iff(C,proof(A,B)),proof_iff(C,proof(B))]); + +s_test_case(proof_parsons_interpret("{\"used\":[\"0\",\"3\",\"5\"],\"available\":[\"1\",\"2\",\"4\",\"6\",\"7\"]}"), proof("0","3","5")); + +s_test_case(proof_inline_maths("\\[ 3 = 2^{\\frac{p}{q}}\\]"), "\\( 3 = 2^{\\frac{p}{q}}\\)"); + +/******************************************************************/ + +s_test_case(proof_damerau_levenstein([1,2,3],[1,2,3]), [0,[]]); +s_test_case(proof_damerau_levenstein([1,2,3],[1,2,3,4]), [1,[dl_ok(1),dl_ok(2),dl_ok(3),dl_add(4)]]); +s_test_case(proof_damerau_levenstein([1,3,4],[1,2,3,4]), [1,[dl_ok(1),dl_add(2),dl_ok(3),dl_ok(4)]]); +s_test_case(proof_damerau_levenstein([3,4],[1,2,3,4]), [2,[dl_add(1),dl_add(2),dl_ok(3),dl_ok(4)]]); +s_test_case(proof_damerau_levenstein([1,3,2,4],[1,2,3,4]), [1,[dl_ok(1),dl_swap(3,2),dl_swap_follow(2),dl_ok(4)]]); + diff --git a/stack/2024060300/maxima/contrib/proofsamples/analysis-sequence-sum-diverge.mac b/stack/2024060300/maxima/contrib/proofsamples/analysis-sequence-sum-diverge.mac new file mode 100644 index 0000000..7c90e73 --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/analysis-sequence-sum-diverge.mac @@ -0,0 +1,23 @@ +/****************************************************************/ +thm:"Proposition: If \\((a_n)\\) diverges to infinity and \\((b_n)\\) converges to \\(b\in\mathbb{R}\\), then the sequence \\((a_n+b_n)\\) diverges to infinity."; + +/****************************************************************/ +proof_steps: [ + ["ass1", "Let \\((a_n)\\) be a sequence that diverges to infinity."], + ["ass2", "Let \\((b_n)\\) be a sequence that converges to a limit \\(b\\)."], + ["ass3", "Let \\(M>0\\)."], + ["defc1", "Let \\(N_1\\) be such that if \\(n>N_1\\) then \\(a_n\\geq M-b+1\\), which exists because \\((a_n)\\) diverges to infinity."], + ["defc2", "Let \\(N_2\\) be such that if \\(n>N_2\\), then \\(|b_n-b|<1\\), which exists from the definition of \\((b_n)\\) converges to \\(b\\) with \\(\\epsilon=1\\). "], + ["s1", "Let \\(N\\) be the maximum of \\(N_1\\) and \\(N_2\\). "], + ["s2", "If \\(n>N\\), then \\(a_n+b_n>(M-b+1)+(b-1)\\)."], + ["s3", "If \\(n>N\\), then \\(a_n+b_n>M\\)."], + ["conc", "\\((a_n+b_n)\\) diverges to infinity."] +]; + +wrong_steps: []; + +proof_steps:append(proof_steps,wrong_steps); + +ta:proof(proof_c("ass1","ass2","ass3"),proof_c("defc1","defc2"),"s1","s2","s3","conc"); +ta2:proof(proof_c(proof(proof_c("ass1","ass3"),"defc1"),proof("ass2","defc2")), "s1","s2","s3","conc"); +tal:append(proof_alternatives(ta),proof_alternatives(ta2)); diff --git a/stack/2024060300/maxima/contrib/proofsamples/harmonic-series.mac b/stack/2024060300/maxima/contrib/proofsamples/harmonic-series.mac new file mode 100644 index 0000000..5008fda --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/harmonic-series.mac @@ -0,0 +1,16 @@ +/****************************************************************/ +thm:"The harmonic series diverges."; + + +/****************************************************************/ +proof_steps: [ + ["defn_pn", "Define \\(p_n\\) to be the \\(n\\)th prime number."], + ["pn_gt_n", "We know that \\(p_n \\geq n > 0\\) for all natural numbers \\(n\\)."], + ["pn_lt_n", "Hence \\(\\frac{1}{p_n} \\leq \\frac{1}{n}\\) for all natural numbers \\(n\\)."], + ["pn_div", "We know that \\(\\sum_{n=1}^\\infty \\frac{1}{p_n}\\) diverges."], + ["comptst", "Apply the comparison test: if \\(a_n \\leq b_n\\) and \\(\\sum_{n=1}^\\infty a_n\\) diverges then \\(\\sum_{n=1}^\\infty b_n\\) diverges."], + ["conc", "The harmonic series diverges."] + ]; + +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof("defn_pn","pn_gt_n","pn_lt_n","pn_div","comptst","conc"); diff --git a/stack/2024060300/maxima/contrib/proofsamples/index.md b/stack/2024060300/maxima/contrib/proofsamples/index.md new file mode 100644 index 0000000..720297b --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/index.md @@ -0,0 +1,26 @@ +# Example mathematical proofs + +This directory contains example mathematical proofs and other arguments as samples and test cases for the proof library. + +Each file must define three variables: + +1. a variable `thm` to hold a statement of the theorem. This is a string variable. +2. a variable `proof_steps`, which is a list of `["key", "proof string"]` pairs. +3. a variable `proof_ans` which represents the proof. + +A teacher refers to the individual steps in the proof using + +1. the short `"key"` string. +2. the integer position in the proof. + +For example, if we have "\(\log_2(3)\) is irrational." then the teacher can define the proof as a list of steps using keys as follows. + + proof_ans:proof("assume","defn_rat","defn_rat2","defn_log","defn_log2","alg","alg_int","contra","conc"); + +The function `proof` represents a proof. Rather than using a list, which has no type information, using the function `proof` signals that this represents a proof. The use of keys, e.g. `"assume"` is more meaningful than numbered steps and it also allows steps to be inserted without re-numbering the steps in a proof. + +For example, if we have theorem "\(n\) is odd if and only if \(n^2\) is odd", then we define its proof as a tree using + + proof_ans:proof_iff(proof(1,2,3,4,5),proof(6,7,8,9,10,11)); + +Really this means the proof is an if and only if proof (`proof_iff`) with two blocks, themselves proofs. The sub-proofs are the most basic proof type, which is a list of steps, e.g. `proof(1,2,3,4,5)`. The steps of a proof are integer indexes to the `proof_steps` list. We deal with indexes, not strings, to simplify the representation and manipulation of the proof trees. diff --git a/stack/2024060300/maxima/contrib/proofsamples/inf-primes.mac b/stack/2024060300/maxima/contrib/proofsamples/inf-primes.mac new file mode 100644 index 0000000..7e8844c --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/inf-primes.mac @@ -0,0 +1,26 @@ +/****************************************************************/ +thm:"There are infinitely many prime numbers."; + + +/****************************************************************/ +proof_steps: [ + ["assume", "Assume, for a contradiction, that there are only a finite number of prime numbers."], + ["false_hyp", "List all the prime numbers \\( p_1, p_2, \\cdots, p_n\\)."], + ["obs1", "Every natural number is either a member of this list, or is divisible by a number on this list."], + ["gadget", "Consider \\(N=p_1\\times p_2 \\times \\cdots \\times p_n +1.\\)"], + + ["notmem1", "For all \\(k=1,\\cdots, n\\) the number \\(N > p_k\\)"], + ["notmem2", "Hence \\(N\\neq p_k\\)."], + ["notmem3", "Therefore \\(N\\) is not a member of the list."], + + ["div1", "For all \\(k=1,\\cdots, n\\) when we divide \\(N\\) by \\(p_k\\) we get remainder \\(1\\)."], + ["div2", "Hence \\(N\\) is not divisible by any \\(p_k\\)."], + + ["contra1", "\\(N\\) is not a member of the list and is not divisible by a number on this list."], + ["contra2", "This contradicts the fact that every number is either a member of this list, or is divisible by a number on this list."], + ["conc", "Therefore the list of prime numbers is not finite."] + ]; + +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof(1,2,3,4,proof_c(proof(5,6,7),proof(8,9)),10,11,12); +proof_ans:proof("assume","false_hyp","obs1","gadget",proof_c(proof("notmem1","notmem2","notmem3"),proof("div1","div2")),"contra1","contra2","conc"); \ No newline at end of file diff --git a/stack/2024060300/maxima/contrib/proofsamples/irrational-power-irrational.mac b/stack/2024060300/maxima/contrib/proofsamples/irrational-power-irrational.mac new file mode 100644 index 0000000..5b623df --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/irrational-power-irrational.mac @@ -0,0 +1,17 @@ +/****************************************************************/ +thm:"An irrational power of an irrational number can be rational."; + + +/****************************************************************/ +proof_steps: [ + ["gadget", "Consider \\(a=\\sqrt{2}^{\\sqrt{2}}\\)."], + ["cases", "Note there are exactly two cases: \\(a\\) is either rational or irrational."], + ["rat-hyp", "Assume \\(a=\\sqrt{2}^{\\sqrt{2}}\\) is rational."], + ["conc", "Then, we have an example where an irrational power of an irrational number can be rational."], + ["irrat-hyp", "Assume \\(a=\\sqrt{2}^{\\sqrt{2}}\\) is irrational."], + ["irrat-1", "Consider \\(\\left(\\sqrt{2}^{\\sqrt{2}}\\right)^{\\sqrt{2}}\\)."], + ["irrat-2", "\\(\\left(\\sqrt{2}^{\\sqrt{2}}\\right)^{\\sqrt{2}}= \\sqrt{2}^{\\sqrt{2}\\times \\sqrt{2}} = \\sqrt{2}^2 = 2\\)."] +]; + +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof_cases(proof("gadget","cases"),proof("rat-hyp","conc"),proof("irrat-hyp","irrat-1","irrat-2","conc")); diff --git a/stack/2024060300/maxima/contrib/proofsamples/log-two-three-irrational.mac b/stack/2024060300/maxima/contrib/proofsamples/log-two-three-irrational.mac new file mode 100644 index 0000000..22ef9c5 --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/log-two-three-irrational.mac @@ -0,0 +1,36 @@ +/****************************************************************/ +thm:"\\(\\log_2(3)\\) is irrational."; + +/****************************************************************/ +proof_steps: [ + ["assume", "Assume, for a contradiction, that \\(\\log_2(3)\\) is rational."], + ["defn_rat", "Then \\(\\log_2(3) = \\frac{p}{q}>0\\) where "], + ["defn_rat2", "\\(p\\) and \\(q\\neq 0\\) are positive integers.", + "This is the definition of rational number."], + ["defn_log", "Using the definition of logarithm:", + "Recall that \\(\\log_a(b)=x \\Leftrightarrow a^x=b\\)."], + ["defn_log2", "\\( 3 = 2^{\\frac{p}{q}}\\)"], + ["con", "if and only if"], + ["alg", "\\( 3^q = 2^p\\)"], + ["alg_int", "The left hand side is always odd and the right hand side is always even."], + ["contra", "This is a contradiction.", + "Notice this is a genuine contradiction, making it difficult to reformulate as a contrapositive."], + ["conc", "Hence \\(\\log_2(3)\\) is irrational."] +]; + +/****************************************************************/ +/* It is possible to add in extra, unnecessary. */ +/****************************************************************/ +wrong_steps:[ + ["assume2", "Assume, for a contradiction, that \\(\\log_2(3)\\) is irrational."], + ["defn_log3", "\\( 2 = 3^{\\frac{p}{q}}\\)"], + ["alg2", "\\( 2^q = 3^p\\)"], + ["alg_int2", "The right hand side is always odd and the left hand side is always even."] +]; +/* Remove this comment to use them! +proof_steps:append(proof_steps,wrong_steps); +*/ + +/****************************************************************/ +proof_ans:proof("assume","defn_rat","defn_rat2","defn_log","defn_log2","con","alg","alg_int","contra","conc"); + diff --git a/stack/2024060300/maxima/contrib/proofsamples/odd-squaredodd.mac b/stack/2024060300/maxima/contrib/proofsamples/odd-squaredodd.mac new file mode 100644 index 0000000..d3e14eb --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/odd-squaredodd.mac @@ -0,0 +1,30 @@ +/****************************************************************/ +thm:"\\(n\\) is odd if and only if \\(n^2\\) is odd."; + +/****************************************************************/ +proof_steps: [ + ["assodd", "Assume that \\(n\\) is odd.", + "This is the hypothesis in the first half of an if any only if proof"], + ["defn_odd", "Then there exists an \\(m\\in\\mathbb{Z}\\) such that \\(n=2m+1\\)."], + ["alg_odd", "\\( n^2 = (2m+1)^2 = 2(2m^2+2m)+1.\\)"], + ["def_M_odd", "Define \\(M=2m^2+2m\\in\\mathbb{Z}\\) then \\(n^2=2M+1\\).", + "Notice we have satisfied the algebraic definition that \\(n^2\\) is an odd number."], + ["conc_odd", "Hence \\(n^2\\) is odd.", + "This is the conclusion in the first half of an if any only if proof"], + + ["contrapos", "We reformulate \"\\(n^2\\) is odd \\(\\Rightarrow \\) \\(n\\) is odd \" as the contrapositive.", + "This reformulation enables us to start with \\(n\\) and not start with \\(n^2\\) which is simpler."], + ["assnotodd", "Assume that \\(n\\) is not odd.", + "This is the reformulated hypothesis in the second half of an if any only if proof"], + ["even", "Then \\(n\\) is even, and so there exists an \\(m\\in\\mathbb{Z}\\) such that \\(n=2m\\)."], + ["alg_even", "\\( n^2 = (2m)^2 = 2(2m^2).\\)"], + ["def_M_even", "Define \\(M=2m^2\\in\\mathbb{Z}\\) then \\(n^2=2M\\)."], + ["conc_even", "Hence \\(n^2\\) is even.", + "This is the conclusion in the second half of an if any only if proof" + ] +]; + +/****************************************************************/ +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof_iff(proof(1,2,3,4,5),proof(6,7,8,9,10,11)); +proof_ans:proof_iff(proof("assodd","defn_odd","alg_odd","def_M_odd","conc_odd"),proof("contrapos","assnotodd","even","alg_even","def_M_even","conc_even")); diff --git a/stack/2024060300/maxima/contrib/proofsamples/root-two-irrational.mac b/stack/2024060300/maxima/contrib/proofsamples/root-two-irrational.mac new file mode 100644 index 0000000..5dc8ad6 --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/root-two-irrational.mac @@ -0,0 +1,30 @@ +/****************************************************************/ +thm:"\\(\\sqrt{2}\\) is irrational."; + + +/****************************************************************/ +proof_steps: [ + ["assume", "Assume, for a contradiction, that \\(\\sqrt{2}\\) is rational."], + ["defn_rat", "Then there exist integers \\(p\\) and \\(q\\neq 0\\) such that"], + ["defn_rat2", "\\( \\sqrt{2} = \\frac{p}{q}.\\)"], + ["ass_low", "We can assume that \\(p\\) and \\(q\\) have no common factor, otherwise we can cancel these out."], + ["alg1", "Squaring both sides"], + ["alg2", "\\( 2 = \\frac{p^2}{q^2}\\)"], + ["alg3", "\\( 2q^2=p^2\\)"], + ["p2_even", "Therefore \\(p^2\\) is even."], + ["p_even", "Hence \\(p\\) is even."], + ["def_even", "Say \\(p=2r\\)."], + ["sub1", "Substituting this gives"], + ["sub2", "\\( 2q^2=(2r)^2\\)"], + ["sub3", "\\( 2q^2=4r^2\\)"], + ["sub4", "\\( q^2=2r^2\\)"], + ["q2_even", "Therefore \\(q^2\\) is even."], + ["q_even", "Hence \\(q\\) is even."], + ["both_even", "We have proved that both \\(p\\) and \\(q\\) are even."], + ["com_fac", "This means they have a common factor of \\(2\\)."], + ["cont", "This contradicts the assumption that \\(p\\) and \\(q\\) have no common factor."] +]; + +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19); +proof_ans:proof("assume","defn_rat","defn_rat2","ass_low","alg1","alg2","alg3","p2_even","p_even","def_even","sub1","sub2","sub3","sub4","q2_even","q_even","both_even","com_fac","cont"); diff --git a/stack/2024060300/maxima/contrib/proofsamples/set-equality.mac b/stack/2024060300/maxima/contrib/proofsamples/set-equality.mac new file mode 100644 index 0000000..680483c --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/set-equality.mac @@ -0,0 +1,20 @@ +/****************************************************************/ +thm:"Let \\(f: X \\to Y\\) be a function, and assume that \\(A,B \\subset X\\), and \\(C,D \\subset Y\\) are all non-empty. Then \\(f^{-1}(Y \\setminus C) = X \\setminus f^{-1}(C)\\)."; + +/****************************************************************/ +proof_steps: [ + ["defn_eq", "To prove set equality \\(V=W\\) we have to prove two cases: (i) \\(V\\subseteq W\\), and (ii) \\(W\\subseteq V\\)."], + ["assume_A", "Let \\( x\\in f^{-1}(Y\\setminus C) \\)."], + ["step_a", "Then \\( f(x)\\in Y\\setminus C \\)."], + ["step_b", "This implies \\( f(x)\\not\\in C \\)."], + ["step_c", "Hence \\( x\\not\\in f^{-1}(C) \\)."], + ["conc_A", "Hence \\(x\\in X \\setminus f^{-1}(C)\\)."], + ["assume_B", "Let \\( x\\in X \\setminus f^{-1}(C)\\)."], + ["conc_B", "Hence \\(x\\in f^{-1}(Y \\setminus C)\\)."] +]; + +/****************************************************************/ +/* This is how the teacher defines their answer, as nested proofs. */ +proof_ans:proof_cases(1,proof(2,3,4,5,6),proof(7,5,4,3,8)); +proof_cases("defn_eq",proof("assume_A","step_a","step_b","step_c","conc_A"),proof("assume_B","step_c","step_b","step_a","conc_B")); + diff --git a/stack/2024060300/maxima/contrib/proofsamples/sum-odd-int.mac b/stack/2024060300/maxima/contrib/proofsamples/sum-odd-int.mac new file mode 100644 index 0000000..15d0256 --- /dev/null +++ b/stack/2024060300/maxima/contrib/proofsamples/sum-odd-int.mac @@ -0,0 +1,23 @@ +/****************************************************************/ +thm:"The sum of the first \\(n\\) odd integers, starting from one, is \\(n^2\\)."; + + +/****************************************************************/ +proof_steps: [ + ["defn_p", "Let \\(P(n)\\) be the statement \"\\(\\sum_{k=1}^n (2k-1) = n^2\\)\"."], + + ["base_hyp", "Note that \\(\\sum_{k=1}^1 (2k-1) = 1 = 1^2\\)"], + ["base_conc", "Hence \\(P(1)\\) is true."], + + ["ind_hyp", "Assume \\(P(n)\\) is true."], + ["ind_1", "Then \\(\\sum_{k=1}^{n+1} (2k-1)\\)"], + ["ind_2", "\\( = \\sum_{k=1}^n (2k-1) + (2(n+1)-1)\\)"], + ["ind_3", "\\( = n^2 + 2n +1 = (n+1)^2.\\)"], + ["ind_conc", "Hence \\(P(n+1)\\) is true."], + + ["concp", "Since \\(P(1)\\) is true and \\(P(n+1)\\) follows from \\(P(n)\\) we conclude that \\(P(n)\\) is true for all \\(n\\) by the principle of mathematical induction."] +]; + +/****************************************************************/ +proof_ans:proof_ind(1,proof(2,3),proof(5,6,7,8),9); +proof_ans:proof_ind("defn_p",proof("base_hyp","base_conc"),proof("ind_1","ind_2","ind_3","ind_conc"),"concp"); \ No newline at end of file diff --git a/stack/2024060300/maxima/contrib/validators.mac b/stack/2024060300/maxima/contrib/validators.mac new file mode 100644 index 0000000..8c94f08 --- /dev/null +++ b/stack/2024060300/maxima/contrib/validators.mac @@ -0,0 +1,56 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/****************************************************************/ +/* Bespoke validators for STACK inputs */ +/* */ +/* Chris Sangwin, */ +/* V1.0 June 2023 */ +/* */ +/* Please use this file to add public bespoke validators. */ +/* */ +/****************************************************************/ + +/* The student may not use an underscore anywhere in their input. */ + +validate_underscore(ex) := if is(sposition("_", string(ex)) = false) then "" + else "Underscore characters are not permitted in this input."; + +/* Add in unit-test cases using STACK's s_test_case function. At least two please! */ +/* Place test cases in validators_test.mac */ + +/* The student may not use a user-defined function, or arrays, anywhere in their input. */ +validate_nofunctions(ex):= block([op1,opp], + if atom(ex) then return(""), + op1:ev(op(ex)), + opp:apply(properties, [op1]), + if ev(emptyp(opp) or is(opp=[noun]),simp) then return(sconcat("User-defined functions are not permitted in this input. In your answer ", stack_disp(op1, "i"), " appears to be used as a function. ")), + apply(sconcat, map(validate_nofunctions, args(ex))) +); + +/* The student may only use single-character variable names in their answer. */ +/* This is intended for use when Insert Stars is turned off, but we still want to indicate to students that they may have forgotten a star */ +validate_all_one_letter_variables(ex) := if not(is(ev(lmax(map(lambda([ex2],slength(string(ex2))),listofvars(ex))),simp)>1)) then "" + else "Only single-character variable names are permitted in this input. Perhaps you forgot to use an asterisk (*) somewhere, or perhaps you used a Greek letter."; + +/* This provides more detailed feedback for students who try to enter fully closed or open intervals using [] or () instead of cc(a,b) or oo(a,b). */ +/* It is intended for early courses where students might be new to using this written notation and STACK. */ +/* This does not work well with "Check type of response" turned on, and provides slightly awkward feedback when students take a union of multiple intervals with incorrect syntax. */ +validate_interval_syntax(ex):= block( + if ev(listp(ex),simp) then return(sconcat("To give a closed interval, use cc(",first(args(ex)),",",second(args(ex)),"), not [",first(args(ex)),",",second(args(ex)),"]. ")) + else if ev(ntuplep(ex),simp) then return(sconcat("To give an open interval, use oo(",first(args(ex)),",",second(args(ex)),"), not (",first(args(ex)),",",second(args(ex)),"). ")) + else if is(safe_op(ex)="%union") then apply(sconcat, map(validate_interval_syntax, args(ex))) + else return("") +); diff --git a/stack/2024060300/maxima/contrib/validators_test.mac b/stack/2024060300/maxima/contrib/validators_test.mac new file mode 100644 index 0000000..1a8b21a --- /dev/null +++ b/stack/2024060300/maxima/contrib/validators_test.mac @@ -0,0 +1,49 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/****************************************************************/ +/* Bespoke validators for STACK inputs: test cases */ +/* */ +/* Chris Sangwin, */ +/* V1.0 June 2023 */ +/* */ +/* Please use this file to add public bespoke validators. */ +/* */ +/****************************************************************/ + +s_test_case(validate_underscore(1+a1), ""); +s_test_case(validate_underscore(1+a_1), "Underscore characters are not permitted in this input."); + +s_test_case(validate_nofunctions(1+a1), ""); +s_test_case(validate_nofunctions(sin(n*x)), ""); +s_test_case(validate_nofunctions(-b#pm#sqrt(b^2-4*a*c)), ""); +s_test_case(validate_nofunctions(x(2)), "User-defined functions are not permitted in this input. In your answer \\(x\\) appears to be used as a function. "); +s_test_case(validate_nofunctions(3*x(t)^2), "User-defined functions are not permitted in this input. In your answer \\(x\\) appears to be used as a function. "); +s_test_case(validate_nofunctions(1+f(x+1)), "User-defined functions are not permitted in this input. In your answer \\(f\\) appears to be used as a function. "); +s_test_case(validate_nofunctions(x(2)*y(3)), "User-defined functions are not permitted in this input. In your answer \\(x\\) appears to be used as a function. User-defined functions are not permitted in this input. In your answer \\(y\\) appears to be used as a function. "); + +s_test_case(validate_all_one_letter_variables(1), ""); +s_test_case(validate_all_one_letter_variables((A*x+B)/(x^2+1) + C/x), ""); +s_test_case(validate_all_one_letter_variables((Ax+B)/(x^2+1) + C/x), "Only single-character variable names are permitted in this input. Perhaps you forgot to use an asterisk (*) somewhere, or perhaps you used a Greek letter."); +s_test_case(validate_all_one_letter_variables((theta*x+B)/(x^2+1) + C/x), "Only single-character variable names are permitted in this input. Perhaps you forgot to use an asterisk (*) somewhere, or perhaps you used a Greek letter."); + +s_test_case(validate_interval_syntax(cc(1,2)), ""); +s_test_case(validate_interval_syntax(oo(1,2)), ""); +s_test_case(validate_interval_syntax(%union(cc(1,2),oo(2,3))), ""); +s_test_case(validate_interval_syntax([1,2]), "To give a closed interval, use cc(1,2), not [1,2]. "); +s_test_case(validate_interval_syntax(ntuple(1,2)), "To give an open interval, use oo(1,2), not (1,2). "); +s_test_case(validate_interval_syntax(%union([1,2],ntuple(2,3))), "To give a closed interval, use cc(1,2), not [1,2]. To give an open interval, use oo(2,3), not (2,3). "); +s_test_case(validate_interval_syntax(%union([1,2],%union(oo(1,2),[2,3]))), "To give a closed interval, use cc(1,2), not [1,2]. To give a closed interval, use cc(2,3), not [2,3]. "); + diff --git a/stack/2024060300/maxima/contrib/vectorcalculus.mac b/stack/2024060300/maxima/contrib/vectorcalculus.mac new file mode 100644 index 0000000..2dc2890 --- /dev/null +++ b/stack/2024060300/maxima/contrib/vectorcalculus.mac @@ -0,0 +1,75 @@ +/* Author Luke Longworth + University of Canterbury + Copyright (C) 2024 Luke Longworth + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/****************************************************************/ +/* Vector calculus functions for STACK */ +/* */ +/* V2.0 March 2024 */ +/* */ +/****************************************************************/ + +/* A flag used throughout the file. */ +/* If return_vect is true, then vector answers are returned as an nx1 matrix. */ +/* If return_vect is false, then vector answers are returned as a list. */ +return_vect: true; + +/****************************************************************/ +/* Calculate the gradient vector of a multivariate function */ +/****************************************************************/ +grad(f, [vars]):= block([grad_vec], + vars: flatten(vars), + if emptyp(vars) then vars: listofvars(f), + /* TO-DO: confirm grad should always simplify? */ + grad_vec: map(lambda([ex], ev(diff(f,vars[ex]), simp)), ev(makelist(ii,ii,1,length(vars)), simp)), + if return_vect then return(transpose(matrix(grad_vec))) else return(grad_vec) +); + +/****************************************************************/ +/* Calculate the divergence of a vector-valued function */ +/****************************************************************/ +div(u, [vars]):= block([div_vec], + if matrixp(u) then funcs: list_matrix_entries(u) else funcs: flatten(u), + vars: flatten(vars), + if emptyp(vars) then vars: listofvars(u), + /* TO-DO: confirm div should always simplify? */ + div_vec: map(lambda([ex], ev(diff(funcs[ex],vars[ex]), simp)), ev(makelist(ii,ii,1,length(vars)), simp)), + return(apply("+", div_vec)) +); + +/****************************************************************/ +/* Calculate the curl of a vector-valued function */ +/****************************************************************/ +curl(u, [vars]):= block([cux, cuy, cuz], + if matrixp(u) then [ux,uy,uz]: list_matrix_entries(u) else [ux,uy,uz]: flatten(u), + vars: flatten(vars), + if emptyp(vars) then vars: listofvars(u), + cux: diff(uz,vars[2]) - diff(uy,vars[3]), + cuy: diff(ux,vars[3]) - diff(uz,vars[1]), + cuz: diff(uy,vars[1]) - diff(ux,vars[2]), + if return_vect then return(transpose(matrix([cux,cuy,cuz]))) else return([cux,cuy,cuz]) +); + +/*******************************************************************/ +/* Calculate the directional derivative of a multivariate function */ +/*******************************************************************/ +dir_deriv(f, u, [vars]):= block([unit_u, der], + if matrixp(u) then u: list_matrix_entries(u), + vars: flatten(vars), + if emptyp(vars) then vars: listofvars(f), + unit_u: u/sqrt(u . u), + der: ev(flatten(args(grad(f, vars))) . unit_u,simp), + return(der) +); + diff --git a/stack/2024060300/maxima/contrib/vectorcalculus_test.mac b/stack/2024060300/maxima/contrib/vectorcalculus_test.mac new file mode 100644 index 0000000..5327e1e --- /dev/null +++ b/stack/2024060300/maxima/contrib/vectorcalculus_test.mac @@ -0,0 +1,77 @@ +/* Author Luke Longworth + University of Canterbury + Copyright (C) 2024 Luke Longworth + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/****************************************************************/ +/* Vector calculus functions for STACK */ +/* */ +/* Test cases. */ +/* */ +/* V2.0 March 2024 */ +/* */ +/****************************************************************/ + +s_test_case((return_vect:true, grad(x*y*z,[x,y,z])),matrix([y*z],[x*z],[x*y])); +s_test_case((return_vect:true, grad(x*y*z,x,y,z)),matrix([y*z],[x*z],[x*y])); +s_test_case((return_vect:true, grad(x*y*z)),matrix([y*z],[x*z],[x*y])); +s_test_case((return_vect:false, grad(x*y*z,[x,y,z])),[y*z,x*z,x*y]); +s_test_case((return_vect:false, grad(x*y*z,x,y,z)),[y*z,x*z,x*y]); +s_test_case((return_vect:false, grad(x*y*z)),[y*z,x*z,x*y]); +s_test_case((return_vect:false, grad(x^2 + x)),[2*x+1]); +s_test_case((return_vect:true, grad(a+2*b+3*c+4*d+5*p)),matrix([1],[2],[3],[4],[5])); +s_test_case((return_vect:true, grad(a+2*b+3*c+4*d+5*p,[p,d,c,b,a])),matrix([5],[4],[3],[2],[1])); + +s_test_case(div([x^2*cos(y),y^3],[x,y]), 2*x*cos(y)+3*y^2); +s_test_case(div(transpose(matrix([x^2*cos(y),y^3])),[x,y]), 2*x*cos(y)+3*y^2); +s_test_case(div(matrix([x^2*cos(y),y^3]),[x,y]), 2*x*cos(y)+3*y^2); +s_test_case(div([x^2*cos(y),y^3],[y,x]), -x^2*sin(y)); +s_test_case(div([y^3,x^2*cos(y)],[y,x]), 2*x*cos(y)+3*y^2); +s_test_case(div([x^2*cos(y),y^3]), 2*x*cos(y)+3*y^2); +s_test_case(div(transpose(matrix([x^2*cos(y),y^3]))), 2*x*cos(y)+3*y^2); +s_test_case(div(matrix([x^2*cos(y),y^3])), 2*x*cos(y)+3*y^2); +s_test_case(div([x^2*cos(y),y^3],x,y), 2*x*cos(y)+3*y^2); +s_test_case(div(transpose(matrix([x^2*cos(y),y^3])),x,y), 2*x*cos(y)+3*y^2); +s_test_case(div(matrix([x^2*cos(y),y^3]),x,y), 2*x*cos(y)+3*y^2); + +s_test_case((return_vect: true, curl([x*y*z,x*y*z,x*y*z],[x,y,z])),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl([x*y*z,x*y*z,x*y*z])),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: false, curl([x*y*z,x*y*z,x*y*z],[x,y,z])),[x*z-x*y,x*y-y*z,y*z-x*z]); +s_test_case((return_vect: false, curl([x*y*z,x*y*z,x*y*z])),[x*z-x*y,x*y-y*z,y*z-x*z]); +s_test_case((return_vect: true, curl([x*y*z,x*y*z,x*y*z],[y,z,x])),matrix([x*y-y*z],[y*z-x*z],[x*z-x*y])); +s_test_case((return_vect: true, curl(matrix([x*y*z,x*y*z,x*y*z]),[x,y,z])),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl(matrix([x*y*z,x*y*z,x*y*z]),x,y,z)),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl(matrix([x*y*z,x*y*z,x*y*z]))),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl(matrix([x*y*z],[x*y*z],[x*y*z]),[x,y,z])),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl(matrix([x*y*z],[x*y*z],[x*y*z]),x,y,z)),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); +s_test_case((return_vect: true, curl(matrix([x*y*z],[x*y*z],[x*y*z]))),matrix([x*z-x*y],[x*y-y*z],[y*z-x*z])); + +s_test_case((return_vect: false, dir_deriv(x*y*z,[1,2,2],[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,[1,2,2],[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: false, dir_deriv(x*y*z,[1,2,2])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,[1,2,2])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,[1,2,2],[y,z,x])),(2*y*z)/3+(x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,[1,2,2],x,y,z)),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: false, dir_deriv(x*y*z,matrix([1,2,2]),[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,matrix([1,2,2]),[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: false, dir_deriv(x*y*z,matrix([1,2,2]))),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,matrix([1,2,2]))),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,matrix([1,2,2]),[y,z,x])),(2*y*z)/3+(x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,matrix([1,2,2]),x,y,z)),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: false, dir_deriv(x*y*z,transpose([1,2,2]),[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,transpose([1,2,2]),[x,y,z])),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: false, dir_deriv(x*y*z,transpose([1,2,2]))),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,transpose([1,2,2]))),(y*z)/3+(2*x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,transpose([1,2,2]),[y,z,x])),(2*y*z)/3+(x*z)/3+(2*x*y)/3); +s_test_case((return_vect: true, dir_deriv(x*y*z,transpose([1,2,2]),x,y,z)),(y*z)/3+(2*x*z)/3+(2*x*y)/3); + diff --git a/stack/2024060300/maxima/elementary.mac b/stack/2024060300/maxima/elementary.mac new file mode 100644 index 0000000..f495a9a --- /dev/null +++ b/stack/2024060300/maxima/elementary.mac @@ -0,0 +1,195 @@ +/* Author Chris Sangwin + University of Birmingham + Copyright (C) 2013 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + + +/* THIS IS EXPERIMENTAL CODE */ +/* Most of the code is now in noun_simp.mac. This is the remainder. */ + + +/*******************************************/ +/* Control functions */ +/*******************************************/ + +DIS_TRANS:["disAddMul"]$ +POW_TRANS:["powLaw"]$ +BUG_RULES:["buggyPow","buggyNegDistAdd"]$ + +/* Is the rule applicable at the top level? */ +trans_topp(ex,rl):=apply(parse_string(sconcat(rl,"p")),[ex])$ + +/* Is the rule applicable anywhere in the expression? */ +trans_anyp(ex, rl):=block( + if atom(ex) then return(trans_topp(ex,rl)), + if trans_topp(ex,rl) then return(true), + apply("or",maplist(lambda([ex2],trans_anyp(ex2,rl)),args(ex))) +)$ + +/* Identify applicable rules at the top level */ +trans_top(ex):=sublist(ALL_TRANS, lambda([ex2],trans_topp(ex,ex2)))$ + +/* Identify applicable rules */ +trans_any(ex):=sublist(ALL_TRANS, lambda([ex2],trans_anyp(ex,ex2)))$ + +/*******************************************/ +/* Higher level control functions */ +/*******************************************/ + +/* Very inefficient! */ +/* Has the advantage that the whole expression is always visible at the top level */ +step_through(ex):=block([rls], + rls:trans_any(ex), + if emptyp(rls) then return(ex), + print(string(ex)), + print(rls), + step_through(transr(ex,first(rls))) +)$ + +/* This only looks at the top level for rules which apply. If none, we look deeper. */ +/* This is much more efficient */ +step_through2(ex):=block([rls,rl,ex2], + if atom(ex) then return(ex), + rls:trans_top(ex), + if emptyp(rls) then return(block([ex2], ex2:map(step_through2,ex), if ex=ex2 then ex else step_through2(ex2))), + rl:first(rls), + ex2:apply(parse_string(rl),[ex]), + print([ex,rl,ex2]), + if ex=ex2 then ex else step_through2(ex2) +)$ + +/* Assume some rules are just applied in the background */ +step_through3(ex):=block([rls], + rls:sublist(ALG_TRANS, lambda([ex2],trans_anyp(ex,ex2))), + if not(emptyp(rls)) then return(step_through3(transr(ex,first(rls)))), + rls:trans_any(ex), + if emptyp(rls) then return(ex), + print(string(ex)), + print(rls), + step_through3(transr(ex,first(rls))) +)$ + +/* removes elements of l1 from l2. */ +removeoncelist(l1,l2):=block( + if listp(l2)#true or emptyp(l2) then return([]), + if listp(l1)#true or emptyp(l1) then return(l2), + if element_listp(first(l1),l2) then return(removeoncelist(rest(l1),removeonce(first(l1),l2))), + removeoncelist(rest(l1),l2) +)$ + +/* A special function. + If a\in l1 is also in l2 then remove a and -a from l2. + Used on negDef */ +removeoncelist_negDef(l1,l2):=block( + if listp(l2)#true or emptyp(l2) then return([]), + if listp(l1)#true or emptyp(l1) then return(l2), + if element_listp(first(l1),l2) then return(removeoncelist_negDef(rest(l1),removeonce("-"(first(l1)),removeonce(first(l1),l2)))), + removeoncelist_negDef(rest(l1),l2) +)$ + +/*******************************************/ +/* Transformation rules (not used) */ +/*******************************************/ + +/* -1*x -> -x */ +negMinusOnep(ex):=block( + if safe_op(ex)#"*" then return(false), + if is(first(args(ex))=negInt(-1)) then return(true) else return(false) +)$ + +negMinusOne(ex):=block( + if negMinusOnep(ex)#true then return(ex), + if length(args(ex))>2 then "-"(apply("*",rest(args(ex)))) else -second(args(ex)) +)$ + +/* a-a -> 0 */ +/* This is a complex function. If "a" and "-a" occur as arguments in the sum + then we remove the first occurance of each. Then we add the remaining arguments. + Hence, this does not flatten arguments or re-order them, but does cope with nary-addition +*/ +negDefp(ex):=block([a0,a1,a2,a3], + if safe_op(ex)#"+" then return(false), + a1:maplist(first,sublist(args(ex), lambda([ex2],safe_op(ex2)="-"))), + a2:sublist(args(ex), lambda([ex2],safe_op(ex2)#"-")), + any_listp(lambda([ex2],element_listp(ex2,a2)),a1) +)$ + +negDef(ex):=block([a0,a1,a2,a3], + if negDefp(ex)#true then return(ex), + a0:args(ex), + a1:maplist(first,sublist(args(ex), lambda([ex2],safe_op(ex2)="-"))), + a2:sublist(args(ex), lambda([ex2],safe_op(ex2)#"-")), + a3:removeoncelist_negDef(a1,a0), + if emptyp(a3) then 0 else apply("+",a3) +)$ + +/* Distributes "-" over addition */ +negDistAddp(ex):=block( + if safe_op(ex)#"-" then return(false), + if safe_op(part((ex),1))="+" then true else false +)$ + +negDistAdd(ex):=block( + if negDistAddp(ex) then map("-",part((ex),1)) else ex +)$ + + + +/*******************************************/ +/* Division rules */ + +/* a/a -> 1 */ +idDivp(ex):= if safe_op(ex)="/" and part(ex,1)=part(ex,2) and part(ex,2)#0 then true else false$ +idDiv(ex) := if idDivp(ex) then 1 else ex$ + +/*******************************************/ +/* Distribution rules */ + +/* Write (a+b)*c as a*c+b*c */ +disAddMulp(ex):= if safe_op(ex)="*" then + if safe_op(last(ex))="+" then true else false$ + +disAddMul(ex):= block([S,P], + S:last(ex), + P:reverse(rest(reverse(args(ex)))), + P:if length(P)=1 then first(P) else apply("*", P), + S:map(lambda([ex], P*ex), S) +)$ + +/*******************************************/ +/* Power rules */ + +/* Write a*a^n as a^(n+m) */ +powLawp(ex):= block([B], + if not(safe_op(ex)="*") then return(false), + B:sort(maplist(lambda([ex], if safe_op(ex)="^" then first(args(ex)) else ex), args(ex))), + if emptyp(powLawpduplicates(B)) then return(false) else return(true) +)$ + +powLawpduplicates(l):=block( + if length(l)<2 then return([]), + if first(l)=second(l) then return([first(l)]), + return(powLawpduplicates(rest(l))) +)$ + +powLaw(ex):= block([B,l1,l2], + B:sort(maplist(lambda([ex], if safe_op(ex)="^" then first(args(ex)) else ex), args(ex))), + B:first(powLawpduplicates(B)), + l1:sublist(args(ex), lambda([ex], is(ex=B) or (is(safe_op(ex)="^") and is(first(args(ex))=B)))), + l1:maplist(lambda([ex], if is(ex=B) then 1 else second(args(ex))), l1), + l2:sublist(args(ex), lambda([ex], not(is(ex=B) or (is(safe_op(ex)="^") and is(first(args(ex))=B))))), + if l2=[] then return(B^apply("+",l1)), + if length(l2)=1 then l2:first(l2) else l2:apply("*",l2), + return(B^apply("+",l1)*l2) +); + diff --git a/stack/2024060300/maxima/errortostring.lisp b/stack/2024060300/maxima/errortostring.lisp new file mode 100644 index 0000000..df6ba14 --- /dev/null +++ b/stack/2024060300/maxima/errortostring.lisp @@ -0,0 +1,8 @@ +;; Custom version of erromsg() to collect the error as +;; a string after it has been formatted +;; Matti Harjula 2019 + +(defmfun $errormsgtostring () + "errormsgtostring() returns the maxima-error message as string." + (apply #'aformat nil (cadr $error) (caddr (process-error-argl (cddr $error)))) +) diff --git a/stack/2024060300/maxima/expandfeedback.mac b/stack/2024060300/maxima/expandfeedback.mac new file mode 100644 index 0000000..a9aaf28 --- /dev/null +++ b/stack/2024060300/maxima/expandfeedback.mac @@ -0,0 +1,122 @@ +/* Author Chris Sangwin + University of Birmingham + Copyright (C) 2006 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + + +/* Expand tutorial. */ +/* This file should take a product and expand out one level in steps */ +/* Chris Sangwin, 6/11/2006 */ +/* This is experimental code, but may be useful. */ + +COLOR_LIST:["red", "Blue" , "YellowOrange", "Bittersweet" , "BlueViolet" , "Aquamarine", "BrickRed" , "Apricot" , "Brown" , "BurntOrange", "CadetBlue" , "CarnationPink" , "Cerulean" , "CornflowerBlue" , "CyanDandelion" , "DarkOrchid" , "Emerald" , "ForestGreen" , "Fuchsia", "Goldenrod" , "Gray" , "Green" , "JungleGreen", "Lavender" , "LimeGreen" , "Magenta" , "Mahogany" , "Maroon" , "Melon", "MidnightBlue" , "Mulberry" , "NavyBlue" , "OliveGreen" , "Orange", "OrangeRed" , "Orchid" , "Peach" , "Periwinkle" , "PineGreen" , "Plum", "ProcessBlue" , "Purple" , "RawSienna" , "Red" , "RedOrange" , "RedViolet" , "Rhodamine" , "RoyalBlue" , "RoyalPurple" , "RubineRed", "Salmon" , "SeaGreen" , "Sepia" , "SkyBlue" , "SpringGreen" , "Tan", "TealBlue" , "Thistle" , "Turquoise" , "Violet" , "VioletRed" ,"WildStrawberry" , "Yellow" , "YellowGreen" , "BlueGreen" ]$ +COLOR_LIST_LENGTH:length(COLOR_LIST)$ + + +/* We want a list of the summands, but you cannot apply args to an atom */ +make_args_sum(ex) := if atom(ex) then [ex] else + if op(ex)#"+" then [ex] else args(ex)$ + +/* Adds up the elements of a list */ +sum_list(ex) := if listp(ex) then + if length(ex)=1 then ex[1] else apply("+",ex) + else ex$ +/* Multiplies together the elements of a list */ +product_list(ex) := if listp(ex) then + if length(ex)=1 then ex[1] else apply("*",ex) + else ex$ + +make_product(ex) := product_list(maplist(sum_list,ex))$ + +/******************************************************************/ +/* A "step" is a list representing a row in a three column matrix */ +/* eg [ [], [], [] ] */ + +/* display a single step, returning a string */ +display_step(ex) := block([ret,ex1,ex2,ex3], + ex1:" ", ex2:" = ", ex3:" ", + if []#ex[1] then ex1:StackDISP(ex[1][1],""), + if []=ex[2] then ex2:" " else + if ex[2][1]#"=" then ex2:StackDISP(ex[2][1],""), + if []#ex[3] then ex3:StackDISP(ex[3][1],""), + apply(concat,[ex1," & ",ex2," & ",ex3," \\\\ "]) +)$ + +/* Takes a list of steps in a problem, and returns a single LaTeX string */ +display_steps(ex) := block([ret], + if atom(ex) then return(StackDISP(ex,"")), + if listp(ex)#true then return(StackDISP(ex,"")), + /* */ + steps:map(display_step,ex), + ret:append(["\\begin{array}{rcl}"],flatten(steps),[" \\end{array} "]), + ret:apply(concat,ret) + )$ + + +/******************************************************************/ + +/* Tutorial expand. This function expands out the expression ex */ +/* It returns a list of steps */ +tut_expand_one_level(ex) := block([args_ex,args_ex1,cur_step,ret], + /* Make sure we apply this function to a product */ + if atom(ex) then return([ [[ex],[],[]] ]), + if op(ex)#"*" then return([ [[ex],[],[]] ]), + /* Get a list of lists with the arguments of ex */ + args_ex:args(ex), + args_ex:maplist(make_args_sum,args_ex), + /* colour the first summands */ + cur_step:cons(zip_with(texcolor,COLOR_LIST,first(args_ex)),rest(args_ex)), + ret:[ [[ex],["="],[make_product(cur_step)]] ], + /* */ + ex1:args_ex[1], + ex2:args_ex[2], + ex3:rest(args_ex,2), + cur_step:maplist(lambda([x],x*sum_list(ex2)),ex1), + cur_step:cons(zip_with(texcolor,COLOR_LIST,cur_step),ex3), + ret:cons([[],["="],[make_product(cur_step)]],ret), + /* */ + cur_step:maplist(lambda([x],maplist(lambda([y],x*y),ex2)),ex1), + cur_step:maplist(sum_list,cur_step), + cur_step:zip_with(texcolor,COLOR_LIST,cur_step), + cur_step:make_product(cons(cur_step,ex3)), + ret:cons([[],["="],[cur_step]],ret), + /* */ + cur_step:maplist(lambda([x],maplist(lambda([y],x*y),ex2)),ex1), + cur_step:maplist(sum_list,cur_step), + /* BUG: this should only be "one step" of simplification. Currently it does everthing */ + cur_step:ev(sum_list(cur_step),simp), + cur_step:if ex3=[] then cur_step else make_product(cons(cur_step,ex3)), + ret:cons([[],["="],[cur_step]],ret), + /* */ + reverse(ret) +)$ + +/* Tutorial expand. This function expands out the expression ex */ +tut_expand_all_levels(ex) := block([args_ex,first_ex], + if atom(ex) then return([ [[ex],[],[]] ]), + if op(ex)#"*" then return([ [[ex],[],[]] ]), + /* first step */ + args_ex:args(ex), + first_ex:ev(expand(args_ex[1]*args_ex[2]),simp), + if length(args_ex)>2 then + append(tut_expand_one_level(ex), [ [["and"],[],[]] ], tut_expand_all_levels(product_list(cons(first_ex,rest(args_ex,2))))) + else + tut_expand_one_level(ex) +)$ + +tut_expand_full(ex) := block([ret,seps], + ret:tut_expand_all_levels(ex), + ret:append(ret,[ [["Hence"],[],[]], [[ex],["="],[ev(expand(ex),simp)]] ]), + display_steps(ret) +)$ + diff --git a/stack/2024060300/maxima/experimental.mac b/stack/2024060300/maxima/experimental.mac new file mode 100644 index 0000000..ca9d949 --- /dev/null +++ b/stack/2024060300/maxima/experimental.mac @@ -0,0 +1,71 @@ +/* Author Chris Sangwin + Lougborough University + Copyright (C) 2015 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + + +/* THIS IS EXPERIMENTAL CODE */ +/* Currently this is under development by CJS and is not connected to the main STACK codebase */ +/* It sits here because the long-term goal is to incorporate it */ + +/* More general random function - recurses across the structure. + Notice the use of the dummy "protect()" function to stop further evaluation. + E.g. + rand_recurse((5+protect(2))*x^protect(2)+3*x+7); + rand_recurse(sin([x,y,z])); +*/ +rand_recurse(ex) := block( + if (integerp(ex) or floatnump(ex) or matrixp(ex) or listp(ex)) then return(rand(ex)), + if atom(ex) then return(ex), + if op(ex)=protect then return(first(args(ex))), + apply(op(ex), maplist(rand_recurse, args(ex))) + ); + +/* Truncates a polynomial to only terms of degree "d" or less - always expands out */ +poly_truncate(pa,d) := apply("+",maplist(lambda([ex],if hipow(ex,x)>d then 0 else ex), args(expand(pa)))); + +/****************************************************************/ +/* Square root functions for STACK */ +/* */ +/* Chris Sangwin, */ +/* V0.1 August 2015 */ +/* */ +/****************************************************************/ + +/* With simp:false */ + +/* Some examples: +p1: (2 + sqrt (2)) * sqrt (2); +p2:distrib(p1); +p3:sqrt(a)*sqrt(b)*sqrt(b)*sqrt(b)*sqrt(a)*1*sqrt(b)+1; +*/ + +naivesqrt(ex):=block([al], + if atom(ex) then return(ex), + al:args(ex), + if safe_op(ex)="*" then block([alp,alq], + alp:sort(sublist(args(ex), lambda([ex2],equal(safe_op(ex2),"sqrt")))), + alq:sublist(args(ex), lambda([ex2],not(equal(safe_op(ex2),"sqrt")))), + al:append(naivesqrthelper(alp),alq) + ), + if safe_op(ex)="*" and length(al)=1 then return(naivesqrt(first(al))), + apply(op(ex), map(naivesqrt, al)) +); + +naivesqrthelper(ex):=block( + if length(ex)<2 then return(ex), + if equal(first(ex), second(ex)) then return(append([first(args(first(ex)))], naivesqrthelper(rest(rest(ex))))), + append([first(ex)], naivesqrthelper(rest(ex))) +); + + diff --git a/stack/2024060300/maxima/fboundp.mac b/stack/2024060300/maxima/fboundp.mac new file mode 100644 index 0000000..310a43d --- /dev/null +++ b/stack/2024060300/maxima/fboundp.mac @@ -0,0 +1,99 @@ +/* fboundp.mac -- detect different kinds of functions in Maxima + * copyright 2020 by Robert Dodier + * I release this work under terms of the GNU General Public License + * + * See https://github.com/maxima-project-on-github/maxima-packages/blob/master/robert-dodier/fboundp/fboundp.mac + * + * Examples: + * + /* Name of an operator: */ + fboundp("+"); + true; + fboundp_operator("+"); + true; + + infix("//") $ + fboundp("//"); + false; + fboundp_operator("//"); + false; + x // y := y - x $ + fboundp("//"); + true; + fboundp_operator("//"); + true; + + /* Simplifying function defined in Lisp: */ + fboundp(sin); + true; + fboundp_simplifying(sin); + true; + + /* DEFUN (ordinary argument-evaluating) function defined in Lisp: */ + fboundp(expand); + true; + fboundp_ordinary_lisp(expand); + true; + + /* DEFMSPEC (argument-quoting) function defined in Lisp: */ + fboundp(kill); + true; + fboundp_quoting(kill); + true; + + /* Maxima ordinary function: */ + (kill(foo), + foo(x) := x, + fboundp(foo)); + true; + fboundp_ordinary_maxima(foo); + true; + + /* Maxima array function: */ + (kill(bar), + bar[x](y) := x*y, + fboundp(bar)); + true; + fboundp_array_function(bar); + true; + + /* Maxima macro: */ + (kill(baz), + baz(x) ::= buildq([x], x), + fboundp(baz)); + true; + fboundp_maxima_macro(baz); + true; + * + */ + +fboundp(a) := + fboundp_operator(a) + or fboundp_simplifying(a) + or fboundp_ordinary_lisp(a) + or fboundp_quoting(a) + or fboundp_ordinary_maxima(a) + or fboundp_array_function(a) + or fboundp_maxima_macro(a); + +fboundp_operator(a) := + stringp(a) and fboundp (verbify (a)); + +fboundp_simplifying(a) := + symbolp(a) and ?get(a, ?operators) # false; + +fboundp_ordinary_lisp(a) := + symbolp(a) and ?fboundp(a) # false; + +fboundp_quoting(a) := + symbolp(a) and ?get(a, ?mfexpr\*) # false; + +fboundp_ordinary_maxima(a) := + symbolp(a) and ?mget(a, ?mexpr) # false; + +fboundp_array_function(a) := + symbolp(a) and ?mget(a, ?aexpr) # false; + +fboundp_maxima_macro(a) := + symbolp(a) and ?mget(a, ?mmacro) # false; + diff --git a/stack/2024060300/maxima/geometry.mac b/stack/2024060300/maxima/geometry.mac new file mode 100644 index 0000000..9549f02 --- /dev/null +++ b/stack/2024060300/maxima/geometry.mac @@ -0,0 +1,99 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* ************************************************************* */ +/* Geometry related functions added for the GeoGebra input type. */ +/* Function names here should match function names in Geogebra */ +/* ************************************************************* */ + +/** + * Euclidean length of the vector (represented as a list) from the origin to the point. + * + * @param[list] v1 list of values + * @return[scalar expression] the Euclidean length of the vector. + */ +Length(v1) := block([simp], + if not(listp(v1)) then error("Length expects its arguments to be a list."), + simp:true, + sqrt(matrix(v1).transpose(matrix(v1))) +)$ + +s_test_case_simp(0, Length([0,0]))$ +s_test_case_simp(sqrt(2), Length([1,1]))$ +s_test_case_simp(5, Length([3,-4]))$ +s_test_case_simp(7*sqrt(2), Length([7,-7]))$ +s_test_case_simp(2, Length([1,1,1,1]))$ + +/** + * Euclidean distance between points represented as lists. + * If one of the lists is shorter, assume the same value for missing dimensions. + * + * @param[list] v1 list of values + * @param[list] v2 list of values + * @return[scalar expression] the Euclidean distance between two vectors as an expression. + */ +Distance(v1, v2) := block([simp,_i], + if not(listp(v1) and listp(v2)) then error("Distance expects its arguments to be lists."), + simp:true, + sqrt(apply("+", makelist((v1[_i]-v2[_i])^2, _i, 1, min(length(v1), length(v2))))) +)$ + +s_test_case_simp(sqrt(2), Distance([0,0] , [1,1]))$ +s_test_case_simp(1, Distance([0,0] , [1,0]))$ +s_test_case_simp(0, Distance([0,0] , [0,0,0,0]))$ +s_test_case_simp(sqrt((y_1-y_2)^2+(x_1-x_2)^2), Distance([x_1,y_1], [x_2,y_2]))$ +s_test_case_simp(sqrt((x1-x2)^2+(y1-y2)^2), Distance([x1,y1] , [x2,y2]))$ + +/** + * The angle between three points A, B, C. Returns radians. + * Note angles are given between -%pi and %pi (not between 0 and 2*%pi). + * + * @param[list] A list of values + * @param[list] B list of values + * @param[list] C list of values + * @return[scalar expression] the angle, in radians, two vectors AB and BC. + */ +Angle(A, B, C) := block([simp,_i, _v, _w], + if not(listp(A) and listp(B) and listp(C)) then error("Angle expects its arguments to be lists."), + simp:true, + _v:A-B, + _w:C-B, + if Length(_v)=0 or Length(_w)=0 then return(und), + /* v . w = |v| * |w| * cos(alpha) + acos(matrix(_v).transpose(matrix(_w))/(Length(_v)*Length(_w))) + But, the above gives an unsigned angle. I.e. Angle(A,B,C)=Angle(C,B,A), which we don't want. + + |v| * |w| * sin(alpha) = det(v, w) + cos(alpha) = v . w / (|v| * |w|) + tan(alpha) = sin(alpha) / cos(alpha) + => tan(alpha) = det(v, w) / v . w + */ + if is(length(_v) = 2) then return(atan2(determinant(matrix(_v,_w)),matrix(_v).transpose(matrix(_w)))), + /* We don't give signed angles in dimensions bigger than 2. */ + acos(matrix(_v).transpose(matrix(_w))/(Length(_v)*Length(_w))) +)$ + +s_test_case_simp(und, Angle([0,0],[0,0],[0,1]))$ + +s_test_case_simp(%pi/2, Angle([1,0],[0,0],[0,1]))$ +s_test_case_simp(-%pi/2, Angle([0,1],[0,0],[1,0]))$ +s_test_case_simp(%pi/4, Angle([1,1],[0,0],[0,1]))$ +s_test_case_simp(-%pi/4, Angle([1,1],[0,0],[1,0]))$ +s_test_case_simp(%pi/6, Angle([1/2,sqrt(3)/2],[0,0],[0,1]))$ +s_test_case_simp(-%pi/3, Angle([1/2,sqrt(3)/2],[0,0],[1,0]))$ +s_test_case_simp(%pi/6, Angle([1/2,sqrt(3)/2],[0,0],[0,7]))$ + +s_test_case_simp(%pi/2, Angle([1,0,0],[0,0,0],[0,1,0]))$ +s_test_case_simp(%pi/2, Angle([0,1,0],[0,0,0],[1,0,0]))$ diff --git a/stack/2024060300/maxima/inequalities.mac b/stack/2024060300/maxima/inequalities.mac new file mode 100644 index 0000000..3ba94b9 --- /dev/null +++ b/stack/2024060300/maxima/inequalities.mac @@ -0,0 +1,322 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2015 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + + +/********************************************************************/ +/* A package for manipulating inequalities in Maxima. */ +/* */ +/* This file relies on assessment.mac, but not on stackmaxima.mac. */ +/* This makes it useable outside STACK. */ +/* */ +/* Chris Sangwin, */ +/* V0.1 May 2015 */ +/* */ +/********************************************************************/ + +/* Reduces an inequality to either ? > 0 or ? >=0, which is monic in its variable. */ +ineqprepare(ex) := block([op2, ex2], + if mapatom(ex) then return(ex), + if safe_op(ex)="%not" then ex:not_ineq(first(args(ex))), + if mapatom(ex) then return(ex), + if op(ex)="=" then return(make_monic_eq(ev(part(ex,1) - part(ex,2), simp, trigreduce)) = 0), + if op(ex)=">" then return(make_monic(ev(part(ex,1) - part(ex,2), simp, trigreduce)) > 0), + if op(ex)=">=" then return(make_monic(ev(part(ex,1) - part(ex,2), simp, trigreduce)) >= 0), + if op(ex)="<" then return(make_monic(ev(part(ex,2) - part(ex,1), simp, trigreduce)) > 0), + if op(ex)="<=" then return(make_monic(ev(part(ex,2) - part(ex,1), simp, trigreduce)) >= 0), + ex2:args(ex), + ex2:map(ineqprepare, ex2), + return(apply(op(ex), ex2)) +)$ + +/* Turn a single variable polynomial expression into a +1/-1 monic polynomial. + This is used with inequalities. */ +make_monic(ex) := block([v,vc,nc], + if mapatom(ex) then return(ex), + if not(polynomialpsimp(ex)) then return(ex), + ex:expand(ex), + v:listofvars(ex), + if v=[] then return(ex), + /* Divide by the numerical coefficient of the leading term, without losing the minus sign, where possible. */ + nc:numerical_coeff(ex), + if not(is(nc=0)) then ex:ev(expand(ex/abs(nc)), simp), + /* Deal with one special case only here. */ + if is(ex=first(v)-minf) then ex:first(v)+inf, + return(ex) +)$ + +/* Return the numerical coefficient of the leading term in expression. */ +numerical_coeff(ex):= block([v, vc], + v:listofvars(ex), + if v=[] then return(ex), + vc:ratcoef(ex, first(v), degree(ex, first(v))), + if listofvars(vc)=[] then return(vc), + numerical_coeff(vc) +); + +/* This is used with equations. */ +make_monic_eq(ex) := block([v], + if mapatom(ex) then return(ex), + if not(polynomialpsimp(ex)) then return(ex), + ex:ev(factor(ex), simp), + ex:ev(expand(ex), simp), + /* Divide by the coefficient of the highest power. */ + v:listofvars(ex), + if v=[] then return(ex), + poly_normalize(ex, v) +)$ + +/* Determines if we have a linear inequality in one variable. + This function prepares the inequality. */ +linear_inequalityp(ex) := block([ex2], + if atom(ex) then return(false), + if not(">"= op(ex) or "<"= op(ex) or ">="= op(ex) or "<="= op(ex)) then return(false), + ex2:ineqprepare(ex), + if not(is(length(listofvars(ex2))=1)) then return(false), + if not(polynomialp(lhs(ex2), listofvars(ex2))) then return(false), + if is(degree(lhs(ex2), first(listofvars(ex2)))=1) then return(true), + return(false) +)$ + +/* Reformat an interval inequality in an easier to read form, namely a lhs(ex)), + if safe_op(ex) = "<=" then return(rhs(ex) >= lhs(ex)), + if safe_op(ex) = ">" then return(rhs(ex) < lhs(ex)), + if safe_op(ex) = ">=" then return(rhs(ex) <= lhs(ex)), + return(ex) +)$ + +/* Reverses any > or >= inequalities: purely syntactic. + This is useful to ensure only <, or <= occur in an expression when we are testing + equivalence, without too much simplification. EqualsComAss does not do this. */ +make_less_ineq(ex):=block( + if atom(ex) then return(ex), + if op(ex)=">" then return(rhs(ex) rhs(ex)), + if safe_op(ex) = "<=" then return(lhs(ex) >= rhs(ex)), + if safe_op(ex) = ">" then return(lhs(ex) < rhs(ex)), + if safe_op(ex) = ">=" then return(lhs(ex) <= rhs(ex)), + return(ex) +)$ + +/* Negates an inequality. */ +not_ineq(ex):=block( + if atom(ex) then return(not(ex)), + if safe_op(ex) = "<" then return(lhs(ex) >= rhs(ex)), + if safe_op(ex) = "<=" then return(lhs(ex) > rhs(ex)), + if safe_op(ex) = ">" then return(lhs(ex) <= rhs(ex)), + if safe_op(ex) = ">=" then return(lhs(ex) < rhs(ex)), + return(ex) +)$ + +/* ex: a list of inequalities + l: a list of index numbers, + Function negates each inequality as indexed by l. */ +neg_ineq_list(ex, l) := block([k], + if emptyp(l) then return(ex), + for k: 1 thru length(l) do ex[ev(l[k], simp)]:neg_ineq(ex[ev(l[k], simp)]), + ex +)$ + +/*******************************************************************************/ +/* This block of functions removes unessary inequalities from a collection. */ +ineq_rem_redundant(ex) := block([exl,exn,exg,exo,exv, simp], + if atom(ex) then return(ex), + if not(safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="%and" or safe_op(ex)="%or" or safe_op(ex)="and") then + return(ex), + /* Recurse over the expression. */ + ex:apply(op(ex), maplist(ineq_rem_redundant, args(ex))), + + if (safe_op(ex)="nounand" or safe_op(ex)="%and" or safe_op(ex)="and") then exo:[max, min] else exo:[min, max], + exn:sublist(args(ex), lambda([ex2], not(linear_inequalityp(ex2)))), + exl:sublist(args(ex), linear_inequalityp), + /* Separate out expressions in a single variable. */ + exv:listofvars(exl), + exl:maplist(lambda([ex],sublist(exl,lambda([ex2], is(listofvars(ex2)=[ex])))), exv), + /* At this point we have linear inequalities, in a single variable, separated out into lists for each individual variable. */ + exl:maplist(lambda([ex], single_linear_ineq_reduce(ex, exo)), exl), + exl:flatten(exl), + exl:append(exn,exl), + if is(length(exl)=1) then return(first(exl)), + ex:apply(op(ex), exl) +)$ + +/* Take a list of linear inequalities the same single variable, and a list of operators, min/max. + Returns the equivalent inequalities. +*/ +single_linear_ineq_reduce(ex, exo):=block([exg,exl], + ex:maplist(ineqprepare,ex), + /* Separate out into x>?, x>=? and x, >= etc. */ + m3:sort(listify(setify(maplist(second, m2)))), + if (not(odr) and is(exo=max)) or (odr and is(exo = min)) then m3:reverse(m3), + [apply(first(m3), if odr then [first(listofvars(exl)), m1] else [m1, first(listofvars(exl))])] +)$ + + +/*******************************************************************************/ +/* Solve pol a single inequality a standard form. */ +/* ex>0 or ex>=0. */ +ineqorder(ex) := ineq_rem_redundant(ev(ineqprepare(ex), simp))$ + + +/*******************************************************************************/ +/* Takes a real linear inequality in one variable and returns an interval. */ +linear_inequality_to_interval(ex) := block([ex2, v, p, Ans], + if not(linear_inequalityp(ex)) then return(ex), + ex2:ineqprepare(ex), + v:first(listofvars(ex2)), + /* Deal with edge cases involving infinity. */ + if is(lhs(ex2)=v-inf) then return({}), + if is(ex2=(inf-v>0)) then return(all), + if is(ex2=(inf-v>=0)) then return(oc(minf,inf)), + if is(lhs(ex2)=v+minf) then return({}), + if is(ex2=(v+inf>0)) then return(all), + if is(ex2=(v+inf>=0)) then return(co(minf,inf)), + + /* We know this solution will exist. */ + p:rhs(first(solve(lhs(ex2), v))), + /* But we can only create an interval if the value is real! */ + if not(real_numberp(p)) then return({}), + Ans:ex, + if equal(coeff(lhs(ex2), v), 1) then + ( + if op(ex2)=">" then Ans:oo(p, inf), + if op(ex2)=">=" then Ans:co(p, inf) + ), + if equal(coeff(lhs(ex2), v), -1) then + ( + if op(ex2)=">" then Ans:oo(-inf, p), + if op(ex2)=">=" then Ans:oc(-inf, p) + ), + return(Ans) +)$ + +/*******************************************************************************/ +/* Solve a single inequality in a single variable by factoring, */ +/* where possible expressing the result as irreducible inequalities. */ +inequality_factor_solve(ex):=block([ex2, p], + if not(inequalityp(ex)) then return(ex), + if length(listofvars(ex))#1 then return(ex), + ex:ineqprepare(ex), + + /* Don't try to solve inequalities with inf/minf etc. */ + if not(freeof(inf, ex)) or not(freeof(minf,ex)) then return(ex), + + if not(polynomialp(lhs(ex), listofvars(ex))) then return(ex), + exop:op(ex), /* This is for >, >= */ + + ex2:factor(lhs(ex)), + if atom(ex2) then return(ex), + /* Create a list of factors */ + m:false, + if is(safe_op(ex2)="-") then block( + m:true, + ex2:first(args(ex2)) + ), + if is(safe_op(ex2)="/") then ex2:num(ex2), + + if safe_op(fl)="*" then fl:args(ex2) else fl:[ex2], + fl:flatten(maplist(factor_ineq, fl)), + + /* This function returns "true" or "false" rather than all/none to better interact with %or and %and. */ + if is(fl=[]) then return(not(m)), + /* Turn each inequality back into a list. */ + ex2:maplist(lambda([ex],apply(exop,[ex,0])),fl), + if m then ex2[1]:neg_ineq(ex2[1]), + /* Create a list of all even permutations, from which we negate those in the list */ + p:sublist(maplist(listify, listify(powerset(setify(makelist(n, n, length(ex2)))))), lambda([ex], evenp(length(ex)))), + ex3:maplist(lambda([l], neg_ineq_list(copylist(ex2), l)), p), + /* Tidy up the list */ + ex3:maplist(lambda([ex], ineq_rem_redundant(apply("%and", ex))), ex3), + ex3:reverse(sort(ex3)), + if is(length(ex3)=1) then first(ex3) else apply("%or", ex3) +)$ + +/* Return factors of the expression over the reals, but with the parity of the multiplicity. */ +factor_ineq(ex) := block([ex2, m], + if not(polynomialp(ex, listofvars(ex))) then return(ex), + if atom(ex) then [return(ex)], + ex2:ev(factor(ex), simp), + if atom(ex2) then [return(ex)], + /* Create a list of factors */ + if is(op(ex2)="-") then m:true else m:false, + if is(op(ex2)="/") then ex2:num(ex2), + /* Even powers and odd powers matter here. */ + if safe_op(ex) = "^" then + if oddp(second(args(ex))) then + return([first(args(ex))]) + else + return([first(args(ex)),first(args(ex))]), + if safe_op(ex) = "*" then ex:args(ex) else ex:[ex], + /* At this point we need to solve irreducible quadratics, and other equations. */ + ex:maplist(factor_ineq_helper, ex), + /* Remove any numbers. */ + ex:sublist(ex, lambda([ex2], ev(not(is(listofvars(ex2)=[])), simp))), + /* Return a list. */ + return(ex) + )$ + + /* Return the real factors of a polynomial, in factored form. */ + factor_ineq_helper(ex):=block([v,ex2,p,simp], + v:listofvars(ex), + if not(is(length(v)=1)) then return(ex), + if safe_op(ex) = "^" then + if oddp(second(args(ex))) then + (p:false, ex:first(args(ex))) + else + (p:true, ex:first(args(ex))), + ex2:solve(ex, first(v)), + ex2:maplist(rhs, ex2), + ex2:sublist(ex2, real_numberp), + ex2:maplist(lambda([ex3], first(v)-ex3), ex2), + simp:false, + if p then + ex2:append(ex2,ex2), + return(flatten(ex2)) + )$ diff --git a/stack/2024060300/maxima/intervals.mac b/stack/2024060300/maxima/intervals.mac new file mode 100644 index 0000000..b50a6b4 --- /dev/null +++ b/stack/2024060300/maxima/intervals.mac @@ -0,0 +1,963 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2020 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + + +/********************************************************************/ +/* A package for manipulating intervals in Maxima. */ +/* Based on code by Matthew James Read, 2012. */ +/* Re-written, May 2020. Chris Sangwin, */ +/* */ +/* V1.0 May 2020 */ +/* */ +/********************************************************************/ + +/* Deal with unions. */ + +unionp(ex) := if safe_op(ex)="%union" or safe_op(ex)="union" then true else false; + +intersectionp(ex) := if safe_op(ex)="%intersection" then true else false; + +/* Define simple intervals. */ + +/* Defines the check functions for when intervals are entered: */ +cc_num(x,y) := block([Ans], + Ans: 'cc(x,y), /* Makes Ans equal to the original interval. Note the ' to stop evaluation or else it would create an infinite loop. */ + if not ev(real_numberp(x), simp) then /* Checks x is a real number. */ + error("intervals: ",x," should be a real number"), + if not ev(real_numberp(y), simp) then /* Checks y is a real number. */ + error("intervals: ",y," should be a real number"), + if y=x and p<=y) then Ans:true + ), + if op(A)=oo then + ( + if (p>x and p=x and px and p<=y) then Ans:true + ) + ) + elseif op(A)="[" then ( + n:length(A), + while jy1) then + setAns:cons(Aset[i],setAns) + elseif Aset[i]=x1 then ( + if op(B)=oc then B:cc(x1,y1), + if op(B)=oo then B:co(x1,y1) + ) + elseif Aset[i]=y1 then ( + if op(B)=co then B:cc(x1,y1), + if op(B)=oo then B:oc(x1,y1) + ), + i:ev(i+1, simp) + ), + if length(setAns)>0 then (setAns:setify(setAns), Ans: [B,setAns] ) else Ans:B + ) + ) + elseif safe_setp(B) then ( + Args1:args(A), + x1:first(Args1), y1:last(Args1), + Aset:listify(B), + n:length(Aset), + while i<(n+1) do ( + if (Aset[i]y1) then + setAns:cons(Aset[i],setAns) + elseif Aset[i]=x1 then ( + if op(A)=oc then A:cc(x1,y1), + if op(A)=oo then A:co(x1,y1) + ) + elseif Aset[i]=y1 then ( + if op(A)=co then A:cc(x1,y1), + if op(A)=oo then A:oc(x1,y1) + ), + i:ev(i+1, simp) + ), + if length(setAns)>0 then (setAns:setify(setAns), Ans: [A,setAns] ) else Ans:A + ), + + if ( not atom(A) and not atom(B) ) then ( + Args1:args(A), + Args2:args(B), + + if not(atom(A) or safe_setp(A) or atom(B) or safe_setp(B)) then ( + if first(Args1)first(Args2) then swap:true, + if swap=false then ( + x1:first(Args1), + y1:last(Args1), + x2:first(Args2), + y2:last(Args2) + ) else ( + Atemp:A, + A:B, + B:Atemp, + x2:first(Args1), + y2:last(Args1), + x1:first(Args2), + y1:last(Args2) + ), + if x2>y1 then + Ans:[A,B], + if (x2y1) then ( + if (op(A)=cc or op(A)=co) then ( + if (op(B)=oc or op(B)=cc) then + Ans:cc(x1,y2) + elseif (op(B)=oo or op(B)=co) then + Ans:co(x1,y2) + ) + elseif (op(A)=oc or op(A)=oo) then ( + if (op(B)=oc or op(B)=cc) then + Ans:oc(x1,y2) + elseif (op(B)=oo or op(B)=co) then + Ans:oo(x1,y2) + ) + ), + if (x20 then ( + setAns:setify(setAns), + Ans:setAns + ) else ( + Ans:{} + ), + return(Ans) + ), + /* At this point we have both A & B not sets. */ + if not(intervalp(A) and intervalp(B)) then error("interval_simple_intersect expects its arguments to be sets or simple intervals."), + + Args1:args(A), + Args2:args(B), + + if first(Args1)first(Args2)) then ( + swap:true + ), + + if swap=false then ( + x1:first(Args1), + y1:last(Args1), + x2:first(Args2), + y2:last(Args2) + ) else ( + Atemp:A, + A:B, + B:Atemp, + x2:first(Args1), + y2:last(Args1), + x1:first(Args2), + y1:last(Args2) + ), + if x2>y1 then ( + Ans:{} + ), + if (x2y1) then ( + if (op(A)=cc or op(A)=oc) then ( + if (op(B)=cc or op(B)=co) then + Ans:cc(x2, y1) + elseif (op(B)=oo or op(B)=oc) then + Ans:oc(x2, y1) + ) elseif (op(A)=co or op(A)=oo) then ( + if (op(B)=co or op(B)=cc) then + Ans:co(x2, y1) + elseif (op(B)=oo or op(B)=oc) then ( + Ans:oo(x2, y1) + ) + ) + ), + if (x20 do + ( + x:A[1], + i:2, + while i= first( Ans[ev(i+1, simp)] ) then + ( + x:interval_simple_union( Ans[i], Ans[ev(i+1, simp)] ), + if (not op(x) = "[" ) then + ( + Ans:delete( Ans[ev(i+1, simp)], Ans, 1 ), + Ans:delete( Ans[i], Ans, 1 ), + Ans:append( Ans, [x] ), + i:ev(i-1, simp), + n:ev(n-1, simp) + ) + ), + i:ev(i+1, simp) + ), + if length(Ans) = 1 then return(Ans[1]), + Ans:apply(%union, Ans), + Ans +); + +/* Given a union of disjoint sets, returns the "canonical form" of this union: */ +interval_tidy(X) := block([A, Ans:[], n, setpart:{}, x, y, i:1], + X:ev(X, simp), + if X=all then return(all), + if atom(X) then return(Ans:phi), + if listp(X) then X:ev(apply(%union, X), simp), + X:ev(X, %intersection=interval_intersect_nary, simp), + + if not(safe_op(X)="%union" or listp(X)) then ( + Ans:X + ) else ( + A:args(X), + i:1, + n:length(A), + while i1) then + A:interval_connect(A), + if length(setpart)>0 then A:append(args(A), [setpart]), + if is(A=[]) then + A:{} + elseif is(length(A)=1) then + A:first(A), + Ans:A + ), + if Ans=oo(-inf,inf) then return(all), + Ans +)$ + +interval_complement_order_points(X):= + block( [A:X, Ans:[], setpart, n, i:1], + A:interval_tidy(A), + if safe_setp(last(A)) then ( + setpart:listify(last(A)), + A:delete(last(A), A, 1), + n:length(A) + length(setpart), + + while i0 then + ( + if length(A)=0 then + ( + Ans:append( Ans, [ { setpart[1] } ] ), + setpart:delete( setpart[1], setpart, 1 ) + ) + else + ( + if setpart[1] < first( A[1] ) then + ( + Ans:append( Ans, [ { setpart[1] } ] ), + setpart:delete( setpart[1], setpart, 1 ) + ) + else + ( + Ans:append( Ans, [ A[1] ] ), + A:delete( A[1], A, 1 ) + ) + ) + ), + i:ev(i+1, simp) + ) + ) + else Ans:A, + Ans +)$ + +/* Return the set complement of a real set. */ +interval_complement(A):= block([Ans:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), n, i:1], + cc:op(cc), oo:op(oo), co:op(co), oc:op(oc), + + if atom(A) then return(oo(-inf,inf)), + if not (op(A) = "[" or op(A)=%union) then ( + if safe_setp(A) then Ans:interval_set_complement(A) + elseif intervalp(A) then ( + if op(A)=co then + ( + Ans:append( Ans, [ oo(-inf, first(A) ) ] ), + Ans:append( Ans, [ co( last(A), inf) ] ) + ), + if op(A)=cc then + ( + Ans:append( Ans, [ oo(-inf, first(A) ) ] ), + Ans:append( Ans, [ oo( last(A), inf) ] ) + ), + if op(A)=oc then + ( + Ans:append( Ans, [ oc(-inf, first(A) ) ] ), + Ans:append( Ans, [ oo( last(A), inf) ] ) + ), + if op(A)=oo then + ( + Ans:append( Ans, [ oc(-inf, first(A) ) ] ), + Ans:append( Ans, [ co( last(A), inf) ] ) + ) + ) + ) else ( + A:interval_complement_order_points(A), + A:args(A), + + /* Just use DeMorgan's laws. */ + Ans:ev(interval_intersect_list(maplist(lambda([ex2], interval_tidy(interval_complement(ex2))), A)), simp), + + if listp(Ans) and length(Ans)=1 then + Ans:Ans[1] + ), + if listp(Ans) then + Ans:apply(%union, Ans), + Ans +)$ + +/* Take a set of real numbers, and return the %union of intervals not containing these numbers. */ +interval_set_complement(X):= block([A:X, Ans:[], temp, n, i:1], + if is(X=none) then return(all), + if not(setp(X)) then error("interval_set_complement requires a set."), + A:listify(A), + n:length(A), + temp:oo(-inf, A[1]), + Ans:[temp], + while i=0 in the simplifier. + (2) we do need simplification here to reduce execution time. + */ + + if assume_pos then + ex:block([assume_pos:false], ev(stack_single_variable_solver_rec(ex %and (v>=0), v), simp)) + else + ex:ev(stack_single_variable_solver_rec(ex, v), simp), + + if ((safe_op(ex)="[" or safe_op(ex)="%union") and is(length(args(ex))=1)) then ex:first(ex), + + if is(ex={}) then return(none), + if is(ex={v}) then return(all), + if logic_edgep(ex) then return(ex), + if is(equal(ex,oo(-inf,inf))) then return(all), + + rs1:ex, + rs2:false, + if safe_op(ex)="%or" then block( + rs1:ev(sublist(args(ex), realset_soft_p), simp), + rs2:ev(sublist(args(ex), lambda([ex2], not realset_soft_p(ex2))), simp), + if is(length(rs1)=1) then rs1:first(rs1), + if is(rs1=none) then + ex:apply("%or", rs2) + else if is(rs1=all) then + ex:all + else + ex:(if realset_soft_p(rs1) then realsetmake(v, rs1) else rs1) %or apply("%or", rs2) + ), + if safe_op(ex)="%union" or safe_setp(ex) then + ex:realsetmake(v, ex), + + return(ex) +)$ + +stack_single_variable_solver_rec(ex, v) := block([r0, r1, r2], + if atom(ex) then return(ex), + if intervalp(ex) then return(ex), + /* Equations should look real. */ + if not(freeof(%i,ex)) then return(ex), + + if equationp(ex) then ex:subst("%or", "nounor", pm_replace(ex)), + if equationp(ex) then return(ev(stack_single_variable_solver_equation(ex, v), simp)), + if linear_inequalityp(ex) then return(ev(linear_inequality_to_interval(ex), simp)), + + /* Possible recursion from here. */ + if inequalityp(ex) then ex:ev(inequality_factor_solve(ex), simp), + + if safe_op(ex)="%or" or safe_op(ex)="%and" then block( + r0:maplist(lambda([ex2], stack_single_variable_solver_rec(ex2, v)), args(ex)), + r1:ev(sublist(r0, realset_soft_p), simp), + r2:ev(sublist(r0, lambda([ex2], not(realset_soft_p(ex2)))), simp) + ), + if safe_op(ex)="%or" then return(ev(apply("%or", append([interval_tidy(r1)], r2)), simp)), + if safe_op(ex)="%and" then return(ev(apply("%and", append([interval_intersect_list(r1)], r2)), simp)), + + return(ex) +)$ + +/* Solve over the reals only. */ +stack_single_variable_solver_equation(ex, v) := block([sol0, sol1, sol2], + sol0:radcan(solve(ex, v)), + if sol0=[] then return({}), + if logic_edgep(sol0) then return(sol0), + /* We need the "freeof" clause to catch rearrangements of equations. */ + sol1:sublist(sol0, lambda([ex2], is(lhs(ex2)=v) and freeof(v, rhs(ex2)))), + sol2:sublist(sol0, lambda([ex2], not(is(lhs(ex2)=v) and freeof(v, rhs(ex2))))), + sol1:maplist(rhs,sol1), + if emptyp(sol1) then + return({}), + sol1:flatten(setify(sol1)), + if is(length(sol2)=1) then + sol2:first(sol2) + else + sol2:apply("%or", sol2), + return(sol1 %or sol2) +)$ + +/* Calculate the natural domain of a single-variable term. */ +natural_domain(ex) := block([v, ex2, simp], + /* This function requires internal simplification. */ + simp:true, + if atom(ex) then return(all), + v:listofvars(ex), + if is(v=[]) then return(all), + if ev(not(is(length(v)=1)), simp) then return(unknown), + /* We only work over real expressions. */ + if not(is(freeof(%i, ex))) then return(unknown), + /* We only calculate domains of some things. */ + if not(is(freeof(sum, ex))) then return(unknown), + if not(is(freeof(int, ex))) then return(unknown), + v:first(v), + /* Recurse using true/false instead of all/none, then convert. */ + ex2:natural_domain_rec(ex), + if realset_soft_p(ex2) then ex2:realsetmake(v, ex2), + ex2 +)$ + +/* Calculate the natural domain of a single-variable term. */ +/* Calculate the natural domain of a single-variable term. */ +natural_domain_rec(ex) := block([v, ex2], + if atom(ex) then return(all), + v:listofvars(ex), + if is(v=[]) then return(all), + if not(is(length(v)=1)) then return(unknown), + v:first(v), + + if safe_op(ex)="sqrt" then + return(stack_single_variable_solver(first(args(ex))>=0)), + if safe_op(ex)="ln" or safe_op(ex)="log" or safe_op(ex)="lg" then + return(stack_single_variable_solver(first(args(ex))>0)), + if safe_op(ex)="/" then + return(natural_domain_div(ex)), + ex2:map(natural_domain_rec, args(ex)), + /* We have to strip of the realset bit before intersecting. */ + ex2:map(lambda([ex3], if is(safe_op(ex3)="realset") then second(ex3) else ex3), ex2), + /* Only return a define value if we really have one. */ + if any_listp(lambda([ex3], is(ex3=unknown) or not(realset_soft_p(ex3) or is(ex3=true) or is(ex3=false))), ex2) then + ex2:unknown + else + ex2:interval_intersect_list(ex2), + ev(ex2, simp) +)$ + +/* Calculate the natural domain of a quotient. */ +natural_domain_div(ex) := block([dom0,dom1,dom2,dom3], + if not(safe_op(ex)) = "/" then error("natural_domain_div expects its operator to be a division"), + dom1:natural_domain(first(ex)), + if safe_op(dom1) = "realset" then dom1:second(dom1), + dom2:natural_domain(second(ex)), + if safe_op(dom2) = "realset" then dom2:second(dom2), + /* Solve for singularities. */ + dom3:stack_single_variable_solver(second(ex)=0), + if safe_op(dom3) = "realset" then dom3:second(dom3), + /* If we can't solve denom=0 then we assume we have no zeros. */ + if not(realsetp(dom3)) then dom3:none, + dom3:interval_set_complement(dom3), + dom0:apply(%intersection,[dom1,dom2,dom3]), + ev(interval_tidy(dom0), simp) +)$ \ No newline at end of file diff --git a/stack/2024060300/maxima/local.mac b/stack/2024060300/maxima/local.mac new file mode 100644 index 0000000..dda3e04 --- /dev/null +++ b/stack/2024060300/maxima/local.mac @@ -0,0 +1 @@ +/* Site-specific Maxima code can be put here. */ diff --git a/stack/2024060300/maxima/noun_arith.lisp b/stack/2024060300/maxima/noun_arith.lisp new file mode 100644 index 0000000..e6dad35 --- /dev/null +++ b/stack/2024060300/maxima/noun_arith.lisp @@ -0,0 +1,53 @@ +;; Customize Maxima's tex() function. +;; Chris Sangwin 21 Oct 2005. +;; Useful files: +;; \Maxima-5.9.0\share\maxima\5.9.0\share\utils\mactex-utilities.lisp +;; \Maxima-5.9.0\share\maxima\5.9.0\src\mactex.lisp + +(defprop $nounadd tex-mplus tex) +(defprop $nounadd ("+") texsym) +(defprop $nounadd 100. tex-lbp) +(defprop $nounadd 100. tex-rbp) + +(defprop $nounsub tex-prefix tex) +(defprop $nounsub ("-") texsym) +(defprop $nounsub 100. tex-rbp) +(defprop $nounsub 100. tex-lbp) + +(defprop $nounmul tex-nary tex) +(defprop $nounmul "\\," texsym) +(defprop $nounmul 120. tex-lbp) +(defprop $nounmul 120. tex-rbp) + +(defprop $noundiv tex-mquotient tex) +(defprop $noundiv 122. tex-lbp) ;;dunno about this +(defprop $noundiv 123. tex-rbp) + +(defprop $nounpow tex-mexpt tex) +(defprop $nounpow 140. tex-lbp) +(defprop $nounpow 139. tex-rbp) + +(defprop $nounand tex-nary tex) +;;(defprop $nounand ("\\land ") texsym) +(defprop $nounand ("\\,{\\text{ !AND! }}\\, ") texsym) +(defprop $nounand 65. tex-lbp) +(defprop $nounand 65. tex-rbp) +;;(defprop mand ("\\land ") texsym) +(defprop mand ("\\,{\\text{ !AND! }}\\, ") texsym) + +(defprop $nounor tex-nary tex) +;;(defprop $nounor ("\\lor ") texsym) +(defprop $nounor ("\\,{\\text{ !OR! }}\\, ") texsym) +(defprop $nounor 61. tex-lbp) +(defprop $nounor 61. tex-rbp) +;;(defprop mor ("\\lor ") texsym) +(defprop mor ("\\,{\\text{ !OR! }}\\, ") texsym) + +(defprop $nounnot tex-prefix tex) +;;(defprop $nounnot ("\\neg ") texsym) +(defprop $nounnot ("{\\rm !NOT!}") texsym) +(defprop $nounnot 70. tex-lbp) +(defprop $nounnot 70. tex-rbp) +(defprop mnot tex-prefix tex) +;;(defprop mnot ("\\neg ") texsym) +(defprop mnot ("{\\rm !NOT!}") texsym) \ No newline at end of file diff --git a/stack/2024060300/maxima/noun_simp.mac b/stack/2024060300/maxima/noun_simp.mac new file mode 100644 index 0000000..326374c --- /dev/null +++ b/stack/2024060300/maxima/noun_simp.mac @@ -0,0 +1,671 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2021 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* ********************************** */ +/* Noun arithmetic */ +/* ********************************** */ + +/* + These function define arithmetic functions which do + not perform their actual mathematical functions. That is to say + noun forms of the standard arithmetic functions. This is to + give much finer control over the simplification of very elementary + expressions. + + Chris Sangwin 21 Oct 2005. + Chris Sangwin 7 Nov 2009, with help from JHD. + Chris Sangwin April 2021, add finer control. +*/ + +/* Create noun forms of the functions of +, -, *, / and ^ + as follows. + + nounadd + - nounsub + * nounmul + / noundiv + ^ nounpow + = nouneq +*/ + +/* For each of these we do the following. + (1) They are defined as infix and nary operators in Maxima + with the binding precedences of their namesakes. + (2) The tex() function is modified to display them exactly as + their namesakes. This should work with a *mix* of noun and + active operators. + (3) verb_arith(expr) which will replace noun versions with their + active counterparts. + (4) noun_arith(expr) which will replace arithmetic operators with their + noun counterparts. +*/ + +/* (1) */ +nary("nouneq", 150); +nary("nounadd", 100); +prefix("nounsub", 100); +nary("nounmul", 120); +infix("noundiv", 122, 123); +infix("nounpow", 140, 139); +prefix("UNARY_RECIP", 100); + +declare("nounmul", commutative); +declare("nounadd", commutative); + +/* (2) */ +load("noun_arith.lisp"); + +/* (3) */ +declare("nouneq", commutative); +declare("nouneq", lassociative); +declare("nouneq", rassociative); + +verb_arith(ex) := block([a], + ex:subst("=", "nouneq", ex), + ex:subst("+", "nounadd", ex), + ex:subst("*", "nounmul", ex), + ex:subst("-", "nounsub", ex), + ex:subst("/", "noundiv", ex), + ex:subst("^", "nounpow", ex), + define(UNARY_RECIP a, a^(-1)), + ex:ev(ex, UNARY_MINUS=-1), + remfunction("nounadd", "nounmul", "noundiv", "nounpow", "nounsub", "nouneq", "UNARY_RECIP"), + ex +)$ + +/* (4) */ +noun_arith(ex) := block([a], + ex:subst("nouneq", "=", ex), + ex:subst("nounadd", "+", ex), + ex:subst("nounmul", "*", ex), + /* Unary minus really communtes with multiplication. */ + ex:subst(lambda([ex], UNARY_MINUS nounmul ex), "-", ex), + /* Turn 1/x into x^(-1), in a special form */ + ex:subst(lambda([ex1, ex2], ex1 nounmul (UNARY_RECIP ex2)), "/", ex), + define(UNARY_RECIP a, a nounpow (-1)), + ex:ev(subst("nounpow", "^", ex)), + remfunction("UNARY_RECIP"), + ev(ex) +)$ + +noun_arith_full(ex) := block([a], + ex:subst("nouneq", "=", ex), + ex:subst("nounadd", "+", ex), + ex:subst("nounmul", "*", ex), + /* Turn -(7) into integer -7. */ + ex:transr(ex, mminusInt), + /* Unary minus really communtes with multiplication. */ + ex:subst(lambda([ex], UNARY_MINUS nounmul ex), "-", ex), + /* Turn 1/x into x^(-1), in a special form */ + ex:subst(lambda([ex1, ex2], ex1 nounmul (UNARY_RECIP ex2)), "/", ex), + /* Now we have the rules based tests we don't replace UNARY_RECIP. */ + ex:ev(subst("nounpow", "^", ex)), + /* See docs on exp: Instances of 'exp ()' in input are simplified to '%e^'; 'exp' does not appear in simplified expressions. */ + ex:ev(subst(lambda([ex2],%e nounpow ex2), exp, ex)), + ev(ex) +)$ + +/* Assumes we are working in the context of noun operators. */ +gather_reduce(ex) := block( + ex:subst("=", "nouneq", ex), + ex:subst("+", "nounadd", ex), + ex:subst("*", "nounmul", ex), + ex:subst("-", "nounsub", ex), + ex:ev(flatten(ex), simp), + ex:subst("nouneq", "=", ex), + ex:subst("nounadd", "+", ex), + ex:subst("nounmul", "*", ex), -- + ex:subst("nounsub", "-", ex), + ex +)$ + +/* This function recursively applies flatten, i.e. this implements nary simplification. */ +flatten_recurse_nouns(ex) := block( + if atom(ex) then return(ex), + if op(ex)="nounadd" or op(ex)="nounmul" then + return(flatten(apply(op(ex), maplist(flatten_recurse_nouns, args(ex))))), + if safe_op(ex)="nounset" then + return((apply(op(ex), maplist(flatten_recurse_nouns, sort(args(ex)))))), + apply(op(ex), maplist(flatten_recurse_nouns, args(ex))) +)$ + +sort_nouns(ex) := block([exl], + if atom(ex) then return(ex), + exl:maplist(sort_nouns, args(ex)), + if safe_op(ex)="nouneq" or safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="nounnot" or safe_op(ex)="nounset" or op(ex)="nounadd" or op(ex)="nounmul" then + exl:sort(exl), + apply(op(ex), exl) +)$ + +/* Rule which takes (a^n)^-1 when n is an integer to a^-n */ +flatten_pow_minus_one(ex):= block( + if not(safe_op(ex)="nounpow") then return(ex), + if not(second(args(ex))=-1) then return(ex), + if safe_op(first(args(ex)))="nounpow" and integerp(second(args(first(args(ex))))) then return("nounpow"(first(args(first(args(ex)))),-second(args(first(args(ex)))))), + ex +)$ + +/* Recursive rule which takes UNARY_MINUS nounmul n, where n is an integer/float to -n */ +unary_minus_remove(ex):= block([exl], + if atom(ex) then return(ex), + if not(safe_op(ex)="nounmul") or not(is(first(args(ex))=UNARY_MINUS)) then return(apply(op(ex), maplist(unary_minus_remove, args(ex)))), + /* The sort moves any numbers to the front of the list of arguments for *. */ + exl:sort(rest(args(ex))), + if is(length(exl)=1) then return(-first(exl)), + exl[1]:-first(exl), + apply("nounmul", exl) +)$ + +equals_commute_prepare(ex):=block([ex1n], + /* We need to strip out any internal simplification. */ + ex1n:parse_string(string(ex)), + + ex1n:subst(nounset, set, ex1n), + ex1n:noun_arith_full(ex1n), + ex1n:flatten_recurse_nouns(ex1n), + ex1n:sort_nouns(ex1n), + return(ex1n) +)$ + +/* Returns true iff ex1 and ex2 are equal up to commutativity and associativity. */ +equals_commute_associate(ex1, ex2) := block([oldsimp, ret, ex1n, ex2n], + oldsimp:simp, + simp:false, + ret:false, + ex1n:equals_commute_prepare(ex1), + ex2n:equals_commute_prepare(ex2), + + if debug then print([ex1n, ex2n]), + + if is(ex1n=ex2n) then ret:true, + simp:oldsimp, + return(ret) +)$ + +/* An answer test in the context of commutative+associative addition and multiplication. */ +ATEqualComAss(sa, sb) := + block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB], + Validity:true, RawMark:true, FeedBack:"", AnswerNote:"", + + SAA:errcatch(ev(sa, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(sb, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]), + + /* We need a copy here because lists are passed by reference and the coloring of incorrect entries + causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */ + SAA:remove_stackeq(copy(sa)), + SBB:remove_stackeq(copy(sb)), + /* We need to check things are of the same type */ + ret:ATSameTypefun(SAA, SBB), + if ret[2]=false then + (ret[3]:StackAddNote("ATEqualComAss ", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ret[4]]) ), + ret:block([simp:true, ret], ATAlgEquiv(SAA, SBB)), + if ret[2]=false then + (ret[3]:StackAddNote("ATEqualComAss (AlgEquiv-false)", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ""])), + /* Now actually apply this test */ + if equals_commute_associate(SAA, SBB) then + (RawMark:true, AnswerNote:"") + else + (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")), + return([Validity, RawMark, AnswerNote, FeedBack]) +)$ + +/* Legacy support for direct access to this function. */ +alias(ATEqual_com_ass, ATEqualComAss)$ + +/* An answer test in the context of commutative+associative addition and multiplication, with identities. */ +ATEqualComAssRules(sa, sb, so) := + block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB, SOO, debugtest], + oldsimp:simp, + simp:false, + Validity:true, RawMark:true, FeedBack:"", AnswerNote:"", + + SAA:errcatch(ev(sa, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATEqualComAssRules_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(sb, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false,false,StackAddNote("", "ATEqualComAssRules_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(so, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false,false,StackAddNote("", "ATEqualComAssRules_STACKERROR_Opt"), ""]), + so:first(SOO), + if (not(listp(so)) or emptyp(so)) then + return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_List"), StackAddFeedback("", "ATEqualComAssRules_Opt_List")]), + + /* Make sure commutativity and associativity are always in, and tidy up the options. */ + so:ev(unique(flatten(append(so, ALG_TRANS))), simp), + if ev(elementp(testdebug, setify(so)), simp) then block( + debugtest:true, + so:delete(testdebug, so) + ) else debugtest:false, + + if not(all_listp(lambda([ex], ev(elementp(ex, setify(ALL_TRANS)), simp) ), so)) then + return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_Wrong"), StackAddFeedback("", "ATEqualComAssRules_Opt_List")]), + + if any_listp(lambda([ex], ev(subsetp(ex, setify(so)), simp) ), INCOMPATIBLE_TRANS) then + return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_Incompatible"), StackAddFeedback("", "ATEqualComAssRules_Opt_Incompatible")]), + + SAA:remove_stackeq(copy(sa)), + SBB:remove_stackeq(copy(sb)), + + /* We need to check things are of the same type */ + ret:ATSameTypefun(SAA, SBB), + if ret[2]=false then + (ret[3]:StackAddNote("ATEqualComAssRules ", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ret[4]]) ), + ret:block([simp:true, ret], ATAlgEquiv(SAA, SBB)), + /* If they are not algebraically equivalent then we bail. */ + if ret[2]=false then + (ret[3]:StackAddNote("ATEqualComAssRules (AlgEquiv-false)", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ""])), + + /* Put the expressions in basic form. */ + SAA:equals_commute_prepare(SAA), + SBB:equals_commute_prepare(SBB), + + if debug then print(["Transforming", SAA]), + SAA:transl(SAA, so), + if debug then print(["Transforming", SBB]), + SBB:transl(SBB, so), + + AnswerNote:"", + if debugtest then AnswerNote:StackAddNote("ATEqualComAssRules: ", string([SAA, SBB])), + /* Now actually apply this test */ + if is(SAA = SBB) then + RawMark:true + else + RawMark:false, + return([Validity, RawMark, AnswerNote, FeedBack]) +)$ + +/* List of all available rules. */ +ALG_TRANS:[assAdd, assMul, comAdd, comMul]$ +ID_TRANS:[zeroAdd, zeroMul, oneMul, onePow, idPow, zeroPow, zPow, oneDiv]$ +NEG_TRANS:[negNeg, negDiv, negOrd]$ +INT_ARITH:[intAdd, intMul, intPow]$ +DIV_TRANS:[recipMul, divDiv, divCancel]$ + +ALL_TRANS:append(ALG_TRANS, ID_TRANS, NEG_TRANS, DIV_TRANS, INT_ARITH, [intFac, negDist, sqrtRem])$ + +/* Set up a hash table of functions and their corresponding predicate. */ +ALL_TRANSP[assAdd] : assAddp$ +ALL_TRANSP[assMul] : assMulp$ +ALL_TRANSP[comAdd] : comAddp$ +ALL_TRANSP[comMul] : comMulp$ + +ALL_TRANSP[zeroAdd] : zeroAddp$ +ALL_TRANSP[zeroMul] : zeroMulp$ +ALL_TRANSP[oneMul] : oneMulp$ +ALL_TRANSP[onePow] : onePowp$ +ALL_TRANSP[idPow] : idPowp$ +ALL_TRANSP[zeroPow] : zeroPowp$ +ALL_TRANSP[zPow] : zPowp$ +ALL_TRANSP[oneDiv] : oneDivp$ + +ALL_TRANSP[recipMul] : recipMulp$ +ALL_TRANSP[divDiv] : divDivp$ +ALL_TRANSP[divCancel] : divCancelp$ +ALL_TRANSP[negDist] : negDistp$ + +ALL_TRANSP[negNeg] : negNegp$ +ALL_TRANSP[negDiv] : negDivp$ +ALL_TRANSP[negOrd] : negOrdp$ + +ALL_TRANSP[intAdd] : intAddp$ +ALL_TRANSP[intMul] : intMulp$ +ALL_TRANSP[intPow] : intPowp$ +ALL_TRANSP[intFac] : intFacp$ + +ALL_TRANSP[sqrtRem] : sqrtRemp$ + +/* These rules are not included in ALL_TRANS. */ +ALL_TRANSP[mminusInt] : mminusIntp$ + +/* Sets of incompatible rules. */ +INCOMPATIBLE_TRANS : [{intFac, intMul}, {negOrd, negDist}]$ + +/*******************************************/ +/* Top level transformations using rules */ +/*******************************************/ + +/* Is the rule applicable at the top level? */ +trans_topp(ex, rl) := ALL_TRANSP[rl](ex)$ + +/* Transform recursively across an expression. */ +transr(ex, rl) := block( + if listp(rl) then error("transr: only apply one rule using transr."), + if trans_topp(ex, rl) then block([ex2], + ex2:apply(rl, [ex]), + if debug then print(["transr: ", rl, ex, ex2]), + /* If applying the rule changes the expression then do so. */ + if ex=ex2 then return(ex) else return(transr(ex2, rl))) + else return(if mapatom(ex) then ex else map(lambda([ex2], transr(ex2, rl)), ex)) +)$ + +/* Apply a list of rules recursively, in order, until the expression stops changing. */ +transl(ex,rll) := block([ex2], + if not(listp(rll)) or emptyp(rll) then return(ex), + ex2:transl(transr(ex, first(rll)), rest(rll)), + if ex=ex2 then return(ex), + return(transl(ex2,rll)) +)$ + +/* This is a special rule used to make sure the single integer (-7) becomes UNARY_MINUS*7. + The parser takes -7 as ((MMINUS) 7), but when simplified this becomes the integer -7. + We essentially "unsimplify" here to disambiguate. + This rule is not included in the main transformation rule base. */ +mminusIntp(ex):= if integerp(ex) and ex<0 then true else false$ +mminusInt(ex) := if mminusIntp(ex) then (UNARY_MINUS nounmul ev(-1*ex, simp)) else ex$ + +/*******************************************/ +/* Transformation rules. */ +/*******************************************/ + +/* 0+x -> x. Assumes commutativity. */ +zeroAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and length(sublist(args(ex), lambda([ex2], ex2=0)))>0 then true else false$ +zeroAdd(ex) := block([ex2], + if not(zeroAddp(ex)) then return(ex), + ex2:sublist(args(ex), lambda([ex2], not(is(ex2=0)))), + if equal(length(ex2),1) then return(first(ex2)), + return(apply(op(ex), ex2)) +)$ + +/* zeroMul transform 0*x to 0. Assumes commutativity. */ +zeroMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], ex2=0)))>0 then true else false$ +zeroMul(ex) := block( + if zeroMulp(ex) then return(0) else return (ex) +)$ + +/* oneMul transform 1*x to x. Assumes commutaivity. */ +oneMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], ex2=1)))>0 then true else false$ +oneMul(ex) := block([ex2], + if not(oneMulp(ex)) then return(ex), + ex2:sublist(args(ex), lambda([ex2], not(is(ex2=1)))), + if equal(length(ex2),1) then return(first(ex2)), + return(apply(op(ex), ex2)) +)$ + +/* 1^x -> 1 */ +onePowp(ex):= if (safe_op(ex)="^" or safe_op(ex)="nounpow") and is(part(ex, 1)=1) then true else false$ +onePow(ex) := if onePowp(ex) then 1 else ex$ + +/* x^1 -> x */ +idPowp(ex):= if (safe_op(ex)="^" or safe_op(ex)="nounpow") and is(part(ex, 2)=1) then true else false$ +idPow(ex) := if idPowp(ex) then part(ex,1) else ex$ + +/* 0^x -> 0*/ +zeroPowp(ex):= block( + if not(safe_op(ex)="^" or safe_op(ex)="nounpow") or is(part(ex, 2)=0) then return(false), + if is(part(ex,1)=0) then true else false +)$ +zeroPow(ex) := if zeroPowp(ex) then 0 else ex$ + +/* x^0 -> 1*/ +zPowp(ex):= block( + if not(safe_op(ex)="^" or safe_op(ex)="nounpow") or is(part(ex, 1)=0) then return(false), + if is(part(ex, 2)=0) then true else false +)$ +zPow(ex) := if zPowp(ex) then 1 else ex$ + +/* UNARY_RECIP(1) -> 1 (intended to be used with other rules). */ +oneDivp(ex):= if safe_op(ex)="UNARY_RECIP" and part(ex, 1)=1 then true else false$ +oneDiv(ex) := if oneDivp(ex) then 1 else ex$ + +/*****************************************/ + +/* These functions "flatten" sums or products by removing uncessary parentheses + i.e. it enforces associativity. */ +/* Note that the predicates only return true if the rule changes the expression */ +assAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and flatten(ex)#ex then true else false$ +assAdd(ex) := if assAddp(ex) then flatten(ex) else ex$ + +assMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and flatten(ex)#ex then true else false$ +assMul(ex) := if assMulp(ex) then flatten(ex) else ex$ + +/* Define a predicate to sort elements, UNARY_MINUS at the front, UNARY_RECIP at the end. */ +orderelementaryp(exa,exb) := block( + if exa=UNARY_MINUS then return(true), + if exb=UNARY_MINUS then return(false), + if safe_op(exa)="UNARY_RECIP" and safe_op(exb)="UNARY_RECIP" then return(orderlessp(part(exa, 1), part(exb, 1))), + if safe_op(exa)="UNARY_RECIP" then return(false), + return(orderlessp(exa,exb)) +)$ + +/* sort(args(ex), orderelementaryp) does not work :-( */ +elsort(l) := block([l1, l2, la], + la:sublist(l, lambda([ex], atom(ex))), + l1:sublist(l, lambda([ex], not(atom(ex)) and safe_op(ex)#"UNARY_RECIP")), + l2:sublist(l, lambda([ex], not(atom(ex)) and safe_op(ex)="UNARY_RECIP")), + append(sort(la, orderelementaryp), sort(l1, orderelementaryp), sort(l2, orderelementaryp)) +)$ + +/* Sort out the order of elements, i.e. commutativity. */ +/* NOTE: sort(args(ex), orderelementaryp)) should work but does not... */ +comAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and apply(op(ex), elsort(args(ex)))#ex then true else false$ +comAdd(ex) := if comAddp(ex) then apply(op(ex),elsort(args(ex))) else ex$ + +comMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and apply(op(ex), elsort(args(ex)))#ex then true else false$ +comMul(ex) := if comMulp(ex) then apply(op(ex),elsort(args(ex))) else ex$ + + +/* Consolidate products of division: a*UNARY_RECIP(b)*UNARY_RECIP(c) -> a*UNARY_RECIP(b*c) */ +recipMulp(ex) := block([ex2], + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false), + if length(args(ex))=1 then return(false), + ex2:reverse(args(ex)), + if safe_op(first(ex2))="UNARY_RECIP" and safe_op(second(ex2))="UNARY_RECIP" then true else false +)$ +recipMul(ex) := block([ex2], + if not(recipMulp(ex)) then return(ex), + ex2:reverse(args(ex)), + apply(op(ex),append(reverse(rest(rest(ex2))),[UNARY_RECIP(apply(op(ex),[part(second(ex2),1),part(first(ex2),1)]))])) +)$ + +/*******************************************/ +/* Double negation -(-(a)). (Assumes unary minus has been replaced by products of UNARY_MINUS */ +negNegp(ex):= block( + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false), + if length(sublist(args(ex), lambda([ex2], is(ex2=UNARY_MINUS))))>1 then return(true) else return(false) +)$ +negNeg(ex) := block([ex0,ex1,ex2], + if not(negNegp(ex)) then return(ex), + ex1:sublist(args(ex), lambda([ex0], is(ex0=UNARY_MINUS))), + ex2:sublist(args(ex), lambda([ex0], not(is(ex0=UNARY_MINUS)))), + if is(oddp(length(ex1))) then ex2:append([UNARY_MINUS], ex2), + if length(ex2)>1 then apply(op(ex), ex2) else first(ex2) +)$ + +/* Double negation UNARY_RECIP(UNARY_MINUS*x)->UNARY_MINUS*UNARY_RECIP(x). + (Assumes unary minus has been replaced by products of UNARY_MINUS etc.) */ +negDivp(ex):= block( + if not(safe_op(ex)="UNARY_RECIP") then return(false), + /* Edge case we have only 1/- left. */ + if part(ex, 1)=UNARY_MINUS then return(true), + if not(safe_op(part(ex, 1))="*" or safe_op(part(ex, 1))="nounmul") then return(false), + if is(length(sublist(args(part(ex, 1)), lambda([ex2], is(ex2=UNARY_MINUS))))>0) then return(true) else return(false) +)$ +negDiv(ex) := block([ex0, ex1, ex2], + if not(negDivp(ex)) then return(ex), + if part(ex, 1)=UNARY_MINUS then return(UNARY_MINUS), + ex1:sublist(args(part(ex, 1)), lambda([ex0], is(ex0=UNARY_MINUS))), + /* This should not happen, but! */ + if emptyp(ex1) then return(ex), + ex2:sublist(args(part(ex, 1)), lambda([ex0], not(is(ex0=UNARY_MINUS)))), + if length(ex1)>1 then ex1:apply(op(part(ex, 1)), ex1) else ex1:UNARY_MINUS, + if length(ex2)>1 then ex2:apply(op(part(ex, 1)), ex2) else ex2:first(ex2), + return (ex1 nounmul UNARY_RECIP(ex2)) +)$ + +negOrdp(ex) := block([ex2,ex3], + if not(safe_op(ex)="+" or safe_op(ex)="nounadd") then return(false), + /* Order the terms in the sum, strip off any UNARY_MINUS, and compare the leading term. */ + ex2:elsort(args(ex)), + ex3:map(lambda([ex0], if not(safe_op(ex0)="*" or safe_op(ex0)="nounmul") then ex0 + else block([a1], a1:sublist(args(ex0), lambda([ex1], not(ex1=UNARY_MINUS))), if length(a1)=1 then first(a1) else apply(op(ex0), a1) )), ex2), + ex3:elsort(ex3), + not(is(first(ex2)=first(ex3))) +)$ +negOrd(ex) := block([ex0], + if not(negOrdp(ex)) then return(ex), + /* We use commutativity of multiplication to pull UNARY_MINUS to the front. */ + ex0:map(comMul, args(ex)), + ex0:map(lambda([ex1], if (atom(ex1) or not(safe_op(ex1)="*" or safe_op(ex1)="nounmul")) then (UNARY_MINUS nounmul ex1) + else if not(first(args(ex1))=UNARY_MINUS) then (UNARY_MINUS nounmul ex1) + else if length(rest(args(ex1)))=1 then first(rest(args(ex1))) else apply(op(ex1), rest(args(ex1)))), ex0), + return(UNARY_MINUS nounmul (apply(op(ex), ex0))) +)$ + +/* Distribute negation over addition. (Assumes unary minus has been replaced by products of UNARY_MINUS */ +negDistp(ex):= block( + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false), + if length(sublist(args(ex), lambda([ex2], is(ex2=UNARY_MINUS))))=0 then return(false), + if length(sublist(args(ex), lambda([ex2], is(safe_op(ex2)="+" or safe_op(ex2)="nounadd"))))=0 then return(false), + return(true) +)$ +negDist(ex) := block([ex0,ex1,ex2,ex3], + if not(negDistp(ex)) then return(ex), + ex1:sublist(args(ex), lambda([ex0], is(ex0=UNARY_MINUS))), + ex2:sublist(args(ex), lambda([ex0], is(safe_op(ex0)="+" or safe_op(ex0)="nounadd"))), + ex3:sublist(args(ex), lambda([ex0], not(is(ex0=UNARY_MINUS)) and not(is(safe_op(ex0)="+" or safe_op(ex0)="nounadd")))), + ex0:apply(op(first(ex2)),map(lambda([ex4],apply(op(ex),[UNARY_MINUS,ex4])),args(first(ex2)))), + apply(op(ex),append(rest(ex1),rest(ex2),[ex0],ex3)) +)$ + +/* a/(b/c)-> a*(c/b) */ +/* Helper which establishes an expression is "UNARY_RECIP" or a product which contains at least one "UNARY_RECIP" */ +divDivProdp(ex):= block( + if safe_op(ex)="UNARY_RECIP" then return(true), + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false), + return(any_listp(lambda([ex2], is(safe_op(ex2)="UNARY_RECIP")), args(ex))) +)$ +divDivp(ex):= block([ex2], + if safe_op(ex)="UNARY_RECIP" then return(divDivProdp(part(ex,1))), + if not(safe_op(ex)="*" or safe_op(ex)="nunmul") then return(false), + ex2:sublist(args(ex),lambda([ex3], safe_op(ex3)="UNARY_RECIP")), + if emptyp(ex2) then return(false), + ex2:map(first,ex2), + return(any_listp(divDivProdp, ex2)) +)$ + +/* Helper function. + TP is the top product: things which don't get changed (retain original operator). + TR is the argument of the first occurance of UNARY_RECIP. + Returns [TP,TR]: things which don't change and thing which do. + This is complex because we have uncertain numbersof arguments in an nary nounmul, and might be left with none! +*/ +divDivProd(ex):= block([TP,TR], + TP:[], + if safe_op(ex)="UNARY_RECIP" then return([TP,part(ex,1)]), + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return([ex],[]), + TR:first(sublist(args(ex),lambda([ex3], safe_op(ex3)="UNARY_RECIP"))), + if emptyp(TR) then return(ex,[]), + TP:removeonce(TR, args(ex)), + if length(TP)=1 then TP:first(TP) else TP:apply(op(ex), TP) , + return([TP,part(TR,1)]) +)$ +divDiv(ex) := block([ex2,ex3,exo,exl], + if not(divDivp(ex)) then return(ex), + /* Store the operator for later. */ + exo:"nounmul", + if safe_op(ex)="*" then exo:"*", + /* Split expression into bits. */ + ex2:divDivProd(ex), + /* This should not really occur because of the predicate divDivP.... */ + if emptyp(second(ex2)) then return(ex), + ex3:divDivProd(second(ex2)), + /* Reassemble, emoving any empty lists (which are nulls here). */ + exl:sublist([first(ex2),second(ex3),if not(emptyp(first(ex3))) then UNARY_RECIP(first(ex3)) else []], lambda([ex4], not(emptyp(ex4)))), + if length(exl)=1 then first(exl) else flatten(apply(exo,exl)) +)$ + +/* We have a product containing a division. */ +/* This rule implicitly assumes recipMul, i.e. it takes everything in the product. */ +/* This rule will also cancel NEG tokens as needed. */ +divCancelp(ex) := if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], safe_op(ex2)="UNARY_RECIP")))>0 then true else false$ + +divCancel(ex) := block([ex1, ex2, ex3], + if not(divCancelp(ex)) then return(ex), + ex1:sublist(args(ex), lambda([l1], not(safe_op(l1)="UNARY_RECIP"))), + ex2:flatten(map(args, sublist(args(ex), lambda([l1], safe_op(l1)="UNARY_RECIP")))), + ex2:flatten(map(lambda([ex3], if (safe_op(ex3)="*" or safe_op(ex3)="nounmul") then args(ex3) else ex3), ex2)), + /* At this point ex1 is a list of factors in the numerator, and ex2 is a list of factors in the denominator. */ + ex3:list_cancel([ex1,ex2]), + ex1:first(ex3), + ex2:second(ex3), + if emptyp(ex1) and emptyp(ex2) then return(1), + if length(ex2)=1 then ex1:append(ex1,[UNARY_RECIP(first(ex2))]), + if length(ex2)>1 then ex1:append(ex1,[UNARY_RECIP(apply("nounmul", ex2))]), + if length(ex1)=1 then return(first(ex1)), + return(apply("nounmul", ex1)) +)$ + +/**********************************************************/ +/* Dealing with powers. */ + +/* Remove the square root function. */ +sqrtRemp(ex):= is(safe_op(ex)="sqrt")$ +sqrtRem(ex):=first(ex) nounpow (1 nounmul UNARY_RECIP(2))$ + + +/**********************************************************/ +/* We either have an integer, or "UNARY_MINUS * integer". */ +noun_simp_integerp(ex) := if atom(ex) then integerp(ex) else + if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(args(ex))=2 and part(ex, 1)=UNARY_MINUS and atom(part(ex, 2)) and integerp(part(ex, 2)) then true else false$ +notnoun_simp_integerp(ex):=not(noun_simp_integerp(ex))$ + +/* Evaluate integer arithmetic */ +intAddp(ex):= block( + if not(safe_op(ex)="+" or safe_op(ex)="nounadd") then return(false), + if length(sublist(args(ex), noun_simp_integerp))>1 then return(true) else return(false) +)$ +intAdd(ex) := block([a1, a2], + if intAddp(ex)=false then return(ex), + a1:sublist(args(ex), noun_simp_integerp), + a1:map(verb_arith, a1), + a1:mminusInt(ev(apply("+", a1), simp)), + a2:sublist(args(ex), notnoun_simp_integerp), + if length(a2)=0 then a1 + else apply(op(ex),append([a1], a2)) +)$ + +intMulp(ex):= block( + if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false), + if length(sublist(args(ex), integerp))>1 then return(true) else return(false) +)$ +intMul(ex) := block([a1, a2], + if intMulp(ex)=false then return(ex), + a1:sublist(args(ex), noun_simp_integerp), + a1:map(verb_arith, a1), + a1:mminusInt(ev(apply("*", a1), simp)), + a2:sublist(args(ex), notnoun_simp_integerp), + if length(a2)=0 then a1 + else apply(op(ex), append([a1], a2)) +)$ + +intPowp(ex):= block( + if not(safe_op(ex)="^" or safe_op(ex)="nounpow") then return(false), + if integerp(part((ex),1)) and part((ex),1)#0 and integerp(part((ex),2)) and part((ex),2)#0 then return(true) else return(false) +)$ +intPow(ex) := block([a1, a2], + if intPowp(ex)=false then return(ex), + ev(ex, simp) +)$ + +intFacp(ex):= integerp(ex)$ +intFac(ex) := block([a1], + if intFacp(ex)=false then return(ex), + noun_arith(factor(ex)) +)$ diff --git a/stack/2024060300/maxima/numericaltest.mac b/stack/2024060300/maxima/numericaltest.mac new file mode 100644 index 0000000..335b993 --- /dev/null +++ b/stack/2024060300/maxima/numericaltest.mac @@ -0,0 +1,464 @@ +/* ********************************** */ +/* Numerical operations */ +/* ********************************** */ + +/* Support for stateful. */ +alias(ATNumSigFigs_CASSigFigsWrapper, ATNumSigFigs)$ +alias(ATSigFigsStrict_CASSigFigsWrapper, ATSigFigsStrict)$ +alias(ATNumDecPlaces_CASDecPlacesWrapper, ATNumDecPlaces)$ + +ATNumAbsolute(SA, SB, SO) := ATNumerical(SA, SB, SO, "ABSOLUTE")$ +ATNumRelative(SA, SB, SO) := ATNumerical(SA, SB, SO, "RELATIVE")$ + +ATNumerical(SA, SB, SO, numtype) := block([simp:true, RawMark, FeedBack, AnswerNote, ret, SAN, tol], + Validity:true, RawMark:false, + FeedBack:StackAddFeedback("", "ATNumerical_FAILED"), + AnswerNote:StackAddNote("", "ATNumerical_FAILED"), + /* Turn on simplification and error catch */ + SA:errcatch(ev(float(SA), simp, nouns)), + if is(SA = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_SAns")), + SA:SA[1], + SAN:copy(SA), /* Need this for when we have lists etc. */ + SB:errcatch(ev(float(remove_numerical_inert(SB)), simp, nouns, rat)), + if is(SB = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_TAns")), + SB:SB[1], + SO:errcatch(ev(float(SO), simp, nouns, rat)), + if is(SO = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_Opt")), + tol:SO[1], + if not(numberp(tol)) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_tol"))), + + if not(elementp(numtype, {"ABSOLUTE", "RELATIVE"})) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_testname_invalid"))), + + /* Are we dealing with lists? */ + if listp(SB) then + if listp(SAN)#true then + return(StackBasicReturn(false, false, "ATNumerical_SA_not_list")) + else + return(ATNumerical_list(SA, SB, numtype, tol)), + + /* Are we dealing with sets? */ + if safe_setp(SB) then + if safe_setp(SAN)=false then + return(StackBasicReturn(false, false, "ATNumerical_SA_not_set")) + else + return(ATNumerical_set(SA, SB, numtype, tol)), + + /* Are we dealing with numbers? */ + if (debug) then print ([SA,SB,tol]), + if numberp(SAN) then + if numberp(SB) then + if numtype = "ABSOLUTE" then + return([true, numabsolutep(SA, SB, tol), "", ""]) + else + return([true, numrelativep(SA, SB, tol), "", ""]) + else + return(StackBasicReturn(false, false, "ATNumerical_SB_not_number")) + else + return(StackBasicReturn(false, false, "ATNumerical_SA_not_number")), + + ret:[Validity, RawMark, AnswerNote, FeedBack], + return(ret) +)$ + +/* We have to define our own working precision. */ +STACK_NUM_TOL:10E-10$ +numabsolutep(sa,ta,tol) := if ev(abs(float(sa-ta)), simp) < ev(abs(tol)+STACK_NUM_TOL, simp) then true else false; +/* The equality sign below is to accommodate the edge case numrelativep(0.0,0.0,0.0?). Needed for units tests with things like 0m/s. */ +numrelativep(sa,ta,tol) := if ev(abs(float(sa-ta)), simp) <= ev(abs(ta*tol*(1+STACK_NUM_TOL)), simp) then true else false; + +ATNumerical_list(SA, SB, numtype, tol) := block([SAl, SBl, cl, res, fb:"", an:""], + SAl:length(SA), + SBl:length(SB), + if (SAl#SBl) then + return([true, false, StackAddNote("","ATNumerical_wronglen"), StackAddFeedback("", "ATList_wronglen", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]), + + if numtype = "ABSOLUTE" then + cl:zip_with(lambda([ex1,ex2], numabsolutep(ex1, ex2, tol)), SA, SB) + else + cl:zip_with(lambda([ex1,ex2], numrelativep(ex1, ex2, tol)), SA, SB), + + res:apply("and", cl), + if not(res) then block([we], + fb:zip_with(lambda([ex1,ex2],if ex1 then ex2 else texcolor("red", ex2)), cl, SA), + we:maplist(second, sublist(zip_with("[", cl, SA), lambda([ex], not(first(ex))))), + an:StackAddNote("", concat("ATNumerical_wrongentries SA/TA=", string(we))), + fb:StackAddFeedback("", "ATList_wrongentries", stack_disp(fb, "d")) + ), + + return([true, res, an, fb]) +)$ + +ATNumerical_set(SA, SB, numtype, tol) := block([SAl, SBl, cl, res, fbl, fb:"", an:""], + SAl:length(SA), + SBl:length(SB), + if (SAl#SBl) then + return([true, false, StackAddNote("","ATNumerical_wronglen"), StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]), + + /* Why on earth has listify stopped working...?! */ + SA:sort(float(args(SA))), + SB:sort(float(args(SB))), + fbl:num_compare_helper(SA, SB, [], [], tol, numtype), + if emptyp(first(fbl)) and emptyp(second(fbl)) then res:true else res:false, + + if not(res) then block( + fb:setify(reverse(maplist(lambda([ex], texcolor("red", ex)), second(fbl)))), + fb:StackAddFeedback("", "ATList_wrongentries", stack_disp(fb, "d")), + an:StackAddNote("", concat("ATNumerical_wrongentries: TA/SA=", string(reverse(first(fbl))), ", SA/TA=", string(reverse(second(fbl))))) + ), + + return([true, res, an, fb]) +)$ + +/*************************************************** +Need a function which identifies which elements of the student's set, fall within "tolerance-balls" of elements of the teacher's set. + +Takes various arguments +(1) student's list +(2) teacher's list +(3) numbers in the student's list, not within appropriate tolerance of any in the teacher's list +(4) numbers in the teacher's list, which do not occur (approximated) in the student's +(5) tolerance - whether this is absolute or relative to the teacher's answer needs to be sorted out internally to the function. +(6) type - either "ABSOLUTE" or "RELATIVE" + +Returns all of the above + a feedback list. + +All arguments 1-2 are ordered lists of floats, smallest to largest. + +Want sa to lie between +(ta-tol,ta+tol) or (ta-ta*tol,ta+ta*tol) depending on "ABSOLUTE" or "RELATIVE" (respectively) +****************************************************/ +num_compare_helper(sal, tal, missing, excessive, tol, type) := block([sa, ta, f1, f2], + /* If we've run out of answers */ + if emptyp(sal) and emptyp(tal) then return([missing, excessive]), + if emptyp(sal) then return([append(tal, missing), excessive]), + if emptyp(tal) then return([missing, append(sal, excessive)]), + /* Otherwise, we take the first element of the list and calculate */ + /* if sa stackmap_get(digits, "upperbound") then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumSigFigs_WrongDigits"), + FeedBack: StackAddFeedback(FeedBack, "ATNumSigFigs_WrongDigits"), + RawMark: false + ), + /* If excessive digits allowed and provided they better be correct. */ + requiredaccuracy:stackmap_get(digits, "upperbound") + ) else ( + if requiredsigfigs = stackmap_get(digits, "lowerbound") then ( + RawMark: true + ) else if stackmap_get(digits, "lowerbound") <= requiredsigfigs and requiredsigfigs <= stackmap_get(digits, "upperbound") then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumSigFigs_WithinRange"), + RawMark: true + ) else ( + AnswerNote: StackAddNote(AnswerNote, "ATNumSigFigs_WrongDigits"), + FeedBack: StackAddFeedback(FeedBack, "ATNumSigFigs_WrongDigits"), + RawMark: false + ) + ), + + /* Now that digits are clear continue to check the accuracy. Or not. */ + if requiredaccuracy = 0 then return([Validity, RawMark, AnswerNote, FeedBack]), + + /* Remove ephemeral forms from teacher's answers. */ + SB:remove_numerical_inert(SB), + /* SA should be only a number. */ + if (not(ATNumSigFigs_numberp(SA))) then + return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]), + /* Don't simplify until now. */ + if is(_EC(errcatch(SA:ev(SA, simp, nouns)), "") = false) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]), + /* In the case of teacher's options [n,0] we ignore the question of numerical accuracy. */ + if ev(is(asf = 0), simp) then + return([Validity, RawMark, AnswerNote, FeedBack]), + /* Check answers have the same algebraic sign. */ + if ev(not(is(sign(SA)=sign(SB))), simp) then block( + RawMark:false, + FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_WrongSign"), + AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_WrongSign") + ), + SA:ev(abs(SA), simp), + SB:ev(abs(SB), simp), + /* Round the teacher's answer to the correct number of significant figures prior to comparison. */ + SB:significantfigures(SB, nsf), + /* Find a power c0 which puts SB*10^c0 between 0 & 1 */ + if not(is(SB=0) or is(SB=0.0)) then + c0:ev(-floor(log(abs(float(rat(SB))))/log(10)+1), simp) + else + c0:0.0, + /* In the case where we have an option [m,-1] we don't need the numerical accuracy to match for more than m significant figures. */ + if ev(is(asf<0), simp) then block( + SA:significantfigures(SA, nsf), + asf:nsf + ), + ev(c2:float(abs(abs(rat(SA)*10^(c0+floor(asf)))-abs(rat(SB)*10^(c0+floor(asf))))), simp), + if (debug) then print([SA,SB,c0,asf,c2]), + if not(ev(is(c2<(0.5)), simp)) then block( + Validity:true, + RawMark:false, + if ev(is(c2<5), simp) then block( + FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_Inaccurate"), + AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_Inaccurate") + ) else block( + AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_VeryInaccurate") + ) + ), + ret: [Validity, RawMark, AnswerNote, FeedBack], + return(ret) +)$ + +ATSigFigsStrict(SA, SB, requiredsigfigs, rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote], + /* The return value */ + Validity: true, + RawMark: false, + FeedBack: "", + AnswerNote: "", + + /* What if the options do not make sense? */ + /* Note that the options may now be dynamic and evaluated in CAS. */ + if requiredsigfigs <= 0 or not integerp(requiredsigfigs) then ( + return([false, false, "STACKERROR_OPTION.", ""]) + ), + + /* Find the number of digits. */ + digits: sig_figs_from_str(rawsans), + + if requiredsigfigs = stackmap_get(digits, "lowerbound") then ( + RawMark: true + ) else if stackmap_get(digits, "lowerbound") <= requiredsigfigs and requiredsigfigs <= stackmap_get(digits, "upperbound") then ( + AnswerNote: StackAddNote(AnswerNote, "ATSigFigsStrict_WithinRange") + ), + + return([Validity, RawMark, AnswerNote, FeedBack]) +)$ + +ATNumSigFigs_numberp(ex) := block([ts], + ts:ex, + if safe_op(ts)="-" then ts:first(args(ts)), + if floatnump(ts) or integerp(ts) or scientific_notationp(ts) then return(true), + return(false) + )$ + +ATNumDecPlaces(sans,tans,options,rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote,required,val], + Validity: true, + RawMark: true, + FeedBack: "", + AnswerNote: "", + + SAA:errcatch(ev(sans, simp, nouns)), + if (is(SAA = [STACKERROR]) or is(SAA = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(tans, simp, nouns)), + if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(options, simp, nouns)), + if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_Opt"), ""]), + SRR:errcatch(ev(rawans, simp, nouns)), + if (is(SRR = [STACKERROR]) or is(SRR = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_Raw"), ""]), + + /* First check if the students answer is a float. */ + if not ev(floatnump(sans),simp) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_SA_Not_num"), + FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Float"), + RawMark: false, + Validity: false + ), + + /* Now many digits needed? */ + required: ev(options,numer,simp), + + if not integerp(required) or is(required<1) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_OptNotInt"), + FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt", stack_disp(options, "i")), + RawMark: false, + Validity: false + ), + + if Validity then ( + if not(stringp(rawsans)) then rawsans:string(rawsans), + /* Find the number of digits. */ + digits: sig_figs_from_str(rawsans), + + /* Does it match the number of digits? */ + if is(stackmap_get(digits, "decimalplaces")=required) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Correct") + ) else ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Wrong_DPs"), + FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Wrong_DPs"), + RawMark: false + ), + + /* Then the actual value. Simply round to required and + then check the difference. */ + val: ev(float(round(sans*10^required)),simp), + val: ev(val - ev(float(round(remove_displaydp(tans)*10^required)),simp),simp), + val: ev(abs(val),simp), + if is(val < 0.1) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Equiv") + ) else ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Not_equiv"), + RawMark: false + ) + ), + + return([Validity, RawMark, AnswerNote, FeedBack]) +)$ + + +ATNumDecPlacesWrong(sans,tans,options) := block([Validity,RawMark,FeedBack,AnswerNote,_sans,_tans,required], + Validity: true, + RawMark: true, + FeedBack: "", + AnswerNote: "", + + SAA:errcatch(ev(sans, simp, nouns)), + if (is(SAA = [STACKERROR]) or is(SAA = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(tans, simp, nouns)), + if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(options, simp, nouns)), + if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_Opt"), ""]), + + /* First check if the students answer is a number. */ + if not ev(numberp(sans),simp) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_SA_Not_num"), + FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Float"), + RawMark: false, + Validity: false + ), + /* Also teachers answer. */ + if not ev(numberp(remove_numerical_inert(tans)), simp) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Tans_Not_Num"), + RawMark: false, + Validity: false + ), + + /* Now many digits needs to match? */ + required: ev(options,numer,simp), + + if not integerp(required) or is(required<1) then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_OptNotInt"), + FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlacesWrong_OptNotInt", stack_disp(options, "i")), + RawMark: false, + Validity: false + ), + + if Validity then ( + /* Shift the values to same range and cut to the required + match length. */ + _sans:ev(sans,numer), + _tans:ev(remove_numerical_inert(tans),numer), + + /* Special case, if either one is 0. */ + if is(_sans=0) or is(_sans=0.0) or is(_tans=0) or is(_tans=0.0) then ( + RawMark: ev(is(_sans-_tans < 10^-required),numer,simp), + if RawMark then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Correct") + ) else ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Wrong") + ), + return([Validity, RawMark, AnswerNote, FeedBack]) + ), + + /* Now that log(0) has been handled shift the numbers */ + _sans:ev(_sans*10^floor(-log(abs(_sans))/log(10)+required),numer,simp), + _tans:ev(_tans*10^floor(-log(abs(_tans))/log(10)+required),numer,simp), + + /* Truncate extras. */ + _sans:floor(_sans), + _tans:floor(_tans), + + RawMark: ev(is(abs(_sans-_tans) < 0.1),numer,simp), + if RawMark then ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Correct") + ) else ( + AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Wrong") + ) + ), + + return([Validity, RawMark, AnswerNote, FeedBack]) +)$ \ No newline at end of file diff --git a/stack/2024060300/maxima/print-comma.lisp b/stack/2024060300/maxima/print-comma.lisp new file mode 100644 index 0000000..9db57de --- /dev/null +++ b/stack/2024060300/maxima/print-comma.lisp @@ -0,0 +1,68 @@ +(in-package :cl-user) + +(setq stackdecimalsep #\,) + +(defun inject-comma (string comma-char comma-interval) + (let* ((len (length string)) + (offset (mod len comma-interval))) + (with-output-to-string (out) + (write-string string out :start 0 :end offset) + (do ((i offset (+ i comma-interval))) + ((>= i len)) + (unless (zerop i) + (write-char comma-char out)) + (write-string string out :start i :end (+ i comma-interval)))))) + + +(defun print-float (stream arg colonp atp + &optional + (point-char #\.) + (comma-char #\,) + (comma-interval 3)) + "A function for printing floating point numbers, with an interface +suitable for use with the tilde-slash FORMAT directive. The full form +is + + ~point-char,comma-char,comma-interval/print-float/ + +The point-char is used in place of the decimal point, and defaults to +#\\. If : is specified, then the whole part of the number will be +grouped in the same manner as ~D, using COMMA-CHAR and COMMA-INTERVAL. +If @ is specified, then the sign is always printed." + (let* ((sign (if (minusp arg) "-" (if (and atp (plusp arg)) "+" ""))) + (output (format nil "~F" arg)) + (point (position #\. output :test 'char=)) + (whole (subseq output (if (minusp arg) 1 0) point)) + (fractional (subseq output (1+ point)))) + (when colonp + (setf whole (inject-comma whole comma-char comma-interval))) + (format stream "~A~A~C~A" + sign whole point-char fractional))) + +;; Basic usage examples. +;; colonp decides if we group digits or not. +;; atp controls if we print an initial + sign +;; The next arguments are point-char, comma-char and comma interval. +;; printf_float(false, %pi*10^6, true, false, ",", " ", 3); +;; printf_float(false, -%pi*10^6, true, false, ",", ".", 3); + +(defun maxima::$printf_float (stream arg &optional + (colonp t) (atp t) + (point-char #\.) + (comma-char #\,) + (comma-interval 3)) + (flet ((coerce-to-char (s) + (cond ((characterp s) s) + ((and (stringp s) (equal s "")) + (code-char 0)) + ((stringp s) + (car (coerce s 'list))) + ((symbolp s) + (cadr (coerce (format nil "~a" s) 'list))) + (t + ;; fix me + (error "Input needs to be a character or string, found ~a." s))))) + (let ((point-char (coerce-to-char point-char)) + (comma-char (coerce-to-char comma-char)) + (arg (maxima::$float arg))) + (print-float stream arg colonp atp point-char comma-char comma-interval)))) diff --git a/stack/2024060300/maxima/proof.mac b/stack/2024060300/maxima/proof.mac new file mode 100644 index 0000000..cdf6fd7 --- /dev/null +++ b/stack/2024060300/maxima/proof.mac @@ -0,0 +1,20 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* *************************************************************** */ +/* Function associate with dealing with proof */ +/* These need to be in the STACK core, e.g. error trapping etc */ +/* *************************************************************** */ + diff --git a/stack/2024060300/maxima/rtest_assessment_simpboth.mac b/stack/2024060300/maxima/rtest_assessment_simpboth.mac new file mode 100644 index 0000000..3406ce2 --- /dev/null +++ b/stack/2024060300/maxima/rtest_assessment_simpboth.mac @@ -0,0 +1,392 @@ +safe_op(1); +""$ +safe_op(x); +""$ +safe_op(%pi); +""$ +safe_op(z+3); +"+"$ +safe_op(3*z); +"*"$ +safe_op(3^z); +"^"$ +safe_op(3/z); +"/"$ +safe_op(sin(3*z)); +"sin"$ +safe_op((-1)/(1+x^2)); +"/"$ +safe_op(1-x); +"+"$ +safe_op(x-1); +"+"$ +safe_op(-(x-1)); +"-"$ +safe_op(-1/(1+x^2)); +"/"$ +safe_op(-2*x); +"*"$ + +coeff_list(x^2-3*x+5,x); +[5,-3,1]$ + +decimalplaces(1.123456789,3); +1.123$ +decimalplaces(1.123456789,8); +1.12345679$ +decimalplaces(1.1292,2); +1.13$ +decimalplaces(-1.1292,2); +-1.13$ +decimalplaces(%pi,5); +3.14159$ +decimalplaces(%pi,4); +3.1416$ + +significantfigures(11292,2); +11000$ +significantfigures(11292,3); +11300$ +significantfigures(1.1292,3); +1.13$ +significantfigures(0.011292,3); +0.0113$ +significantfigures(0.09999,3); +0.1$ +scientific_notation(1.123); +1.123$ +scientific_notation(1123); +1123.0$ +significantfigures(-0.99,1); +-1$ + +all_listp(real_numberp,[1,exp(1)^(%i*%pi),sqrt(2)+1,sin(1)]); +true$ +any_listp(real_numberp,[%i,%i+1,3+x,sqrt(-3)+1]); +false$ + +expandp((x-1)*(1+x)); +false$ +expandp(2*(x-1)); +false$ +expandp(2*x-1); +true$ +expandp(x-1); +true$ +expandp((p-1)*(1+p)); +false$ +expandp(2*(p-1)); +false$ +expandp(3*y+6*p); +true$ + +ineqprepare(x>1); +x-1>0$ +ineqprepare(3*x<=7-x); +7/4-x>=0$ + +list_expression_numbers(x); +[]$ +list_expression_numbers(%pi); +[]$ +list_expression_numbers(1+x); +[1]$ +list_expression_numbers(1/2+x); +[1/2]$ +list_expression_numbers(4/2+x); +[4/2]$ +list_expression_numbers(1/sin(2*x)); +[1,2]$ + +sublist([0.5],floatnump); +[0.5]$ +sublist([1,0.5],floatnump); +[0.5]$ + +anyfloatex(0.5); +true$ +anyfloatex(x); +false$ +anyfloatex(1+x); +false$ +anyfloatex(0.5*x); +true$ +anyfloatex(sin(x*0.2)); +true$ + +irred_Q(0,x); +[true,"",false]$ +irred_Q(x,x); +[true,"",false]$ +irred_Q(1+x,x); +[true,"",false]$ +irred_Q(1-x,x); +[true,"",false]$ +irred_Q(2-3*x,x); +[true,"",false]$ +irred_Q(2*x-2,x); +[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",true]$ +irred_Q(t+t*x,x); +[false,"",false]$ +irred_Q(3*x^2,x); +[true,"",false]$ +irred_Q(4*x^2,x); +[true,"stack_trans('irred_Q_optional_fac' , !quot!\\(4\\,x^2\\)!quot! ); !NEWLINE!",false]$ +irred_Q(x^2-4,x); +[false,"",false]$ +irred_Q(x^2-2,x); +[true,"",false]$ +irred_Q(n+n^2,n); +[false,"",false]$ +irred_Q(n*(1+n),n); +[false,"",false]$ +irred_Q(n*(n-1),n); +[false,"",false]$ +irred_Q(0.5+x,x); +[true,"",false]$ +irred_Q(2-3*x+x^2,x); +[false,"",false]$ +irred_Q(1+x^2+x^5,x); +[true,"",false]$ +irred_Q(n^3-1,n); +[false,"",false]$ +irred_Q(3*x-6*x^3+3*x^6,x); +[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",false]$ +irred_Q(9-3*x+3*x^5,x); +[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",true]$ + +PartFrac_term_p(2,x); +true$ +PartFrac_term_p(1/(x-1)^2,x); +true$ +PartFrac_term_p(1/(3*x-6)^4,x); +true$ +PartFrac_term_p(1/(x^2-1),x); +false$ +PartFrac_term_p(1/(3*x-6*x^3+3*x^6),x); +false$ +PartFrac_term_p(1/(9-3*x+3*x^5),x); +true$ +PartFrac_term_p(x/(x-1),x); +false$ + +continuousp(x^2,x,1); +true$ +continuousp(abs(x),x,1); +true$ +continuousp(abs(x),x,0); +true$ +continuousp(sgn(x),x,0); +false$ +continuousp(sin(1/x),x,0); +false$ +continuousp(x*sin(1/x),x,0); +true$ + +diffp(x^2,x,1); +true$ +diffp(abs(x),x,1); +true$ +diffp(abs(x),x,0); +false$ +diffp(sgn(x),x,0); +false$ +diffp(sin(1/x),x,0); +false$ +diffp(x^2*sin(1/x),x,0); +false$ +diffp(x^3*sin(1/x),x,0); +true$ + +listsoverlap([1,2],[2,3]); +true$ +listsoverlap([8,9],[2,3]); +false$ +listscontain([1,2],[2,3],1); +false$ +listscontain([8,9],[2,3],1); +false$ +listscontain([1,2],[1,3],1); +true$ + +subst_int_const(x^4/4+c*x+x = %c9,k); +x^4/4+c*x+x = k$ +subst_int_const(x^4/4+c*x+x = %c9,v); +x^4/4+c*x+x = v$ +subst_int_const(x^2,k); +x^2$ +subst_int_const(c*x^4/4+c^2*x/2+c*x = %c9*c+%c10,[v]); +c*x^4/4+c^2*x/2+c*x = %c9*c+v$ +subst_int_const(c*x^4/4+c^2*x/2+c*x = %c9*c+%c10,[k1,k2]); +c*x^4/4+c^2*x/2+c*x = k1+c*k2$ +subst_int_const(c*x^4/4+c^2*x/2+c*x = %c9*c+%c10,[k1,k2,k3]); +c*x^4/4+c^2*x/2+c*x = k1+c*k2$ + +subst_equiv(y+x^2,1+a^2); +[]$ +subst_equiv(1-2*x+x^2,(X-1)^2); +[x = X]$ +subst_equiv(y+x^2,b+a^2); +[x = a,y = b]$ +subst_equiv(y+x^2,b+a^2); +[x = a,y = b]$ +subst_equiv(y/z+x^2,c/b+a^2); +[x = a,y = c,z = b]$ +subst_equiv(y/z+x^2,z/x+y^2); +[x = y,y = z,z = x]$ +subst_equiv(y+x^2,x^2+y^2); +[]$ +subst_equiv(u^6+w^5+v^4+z^3+y^2+x,f+g^2+d^3+c^4+b^5+a^6); +false$ +subst_equiv(w+u+v+y+x^2,w+v+y+b+a^2); +[u = b,x = a]$ + +exdowncase(1+X+X^2); +1+x+x^2$ + +exdowncase(%pi); +%pi$ + +stack_assignmentp(x = 1); +true$ +stack_assignmentp(x = sqrt(2)); +true$ +stack_assignmentp(3 = 1); +false$ +stack_assignmentp(d = v*t); +false$ +stack_assignmentp(1 = x); +false$ + +StackDISP(a/b,""); +"\\frac{a}{b}"$ + +StackDISP(-27,""); +"-27"$ + +StackDISP(-sin(x^2),""); +"-\\sin \\left( x^2 \\right)"$ + +StackDISP(asin(x),""); +"\\sin^{-1} \\left( x \\right)"$ + +StackDISP(log(x),""); +"\\ln \\left( x \\right)"$ + +StackDISP(y^3-2*y^2-8*y,""); +"y^3-2\\,y^2-8\\,y"$ + +StackDISP(y^2-2*y-8,""); +"y^2-2\\,y-8"$ + +StackDISP(y^2-2*y-0.5,""); +"y^2-2\\,y-0.5"$ + +strip_int_const(k+x,x); +x$ +strip_int_const(k+1+x,x); +1+x$ +strip_int_const(k^2+(x-1)^2,x); +(x-1)^2$ +strip_int_const(c+(t-1)^4/4,t); +(t-1)^4/4$ + +buggy_pow((x+1)^2); +x^2+1^2$ +buggy_pow(sin((x+y)^3)); +sin(x^3+y^3)$ + +degree(y^3 * x^2 + x * y^4, x); +2$ +degree((x + y)^5, x); +5$ +degree((x + y)^5, x + y); +0$ + +list_remove([a,b,c,d], 1); +[b,c,d]$ +list_remove([a,b,c,d], 2); +[a,c,d]$ +list_remove([a,b,c,d], 3); +[a,b,d]$ +list_remove([a,b,c,d], 0); +[a,b,c,d]$ +list_remove([a,b,c,d], 6); +[a,b,c,d]$ +list_remove([a,[b],[c,d],d], 2); +[a,[c,d],d]$ + +stack_disp(a+1, "i"); +"\\(a+1\\)"$ + +stack_disp(1, "i"); +"\\(1\\)"$ + +stack_disp(false, "i"); +"\\(\\mathbf{!BOOLFALSE!}\\)"$ + +stack_disp(ab0, "i"); +"\\({\\it ab}_{0}\\)"$ + +stack_disp(epsilon0345, "i"); +"\\({\\varepsilon}_{0345}\\)"$ + +stack_disp(a+1/pi3, "i"); +"\\(a+\\frac{1}{\\pi_{3}}\\)"$ + +stack_disp(gamma7^3, "i"); +"\\(\\gamma_{7}^3\\)"$ + +stack_disp(gamma7^(2*x), "i"); +"\\(\\gamma_{7}^{2\\,x}\\)"$ + +stack_disp(f(x):=2*x^3, "i"); +"\\(f(x):=2*x^3\\)"$ + +stack_unit_si_to_si_base(25); +25$ +stack_unit_si_to_si_base(25*kg); +25*kg$ +stack_unit_si_to_si_base(kg); +kg$ +stack_unit_si_to_si_base(5*g); +(1/200)*kg$ +stack_unit_si_to_si_base(stackunits(25,NULLUNITS)); +stackunits(25,NULLUNITS)$ +stack_unit_si_to_si_base(stackunits(25,kg)); +stackunits(25,kg)$ +stack_unit_si_to_si_base(stackunits(NULLNUMS,kg)); +stackunits(NULLNUMS,kg)$ +stack_unit_si_to_si_base(stackunits(NULLNUM,g)); +stackunits(1/1000,kg)$ +stack_unit_si_to_si_base(stackunits(5,g)); +stackunits(1/200,kg)$ + +stackunits_to_product(stackunits(5,g)); +5*g$ +stackunits_to_product(stackunits(NULLNUM,g)); +g$ +stackunits_to_product(stackunits(6,NULLUNITS)); +6$ + +factorlist(15); +[3,5]$ +factorlist(x^2); +[x]$ +factorlist(x^2-1); +[x-1,x+1]$ +factorlist(x^2-2); +[x^2-2]$ +factorlist(-x^2); +[x]$ +factorlist(1-x^2); +[x-1,x+1]$ +factorlist(x^2-5*x+6); +[x-3,x-2]$ +factorlist(-x^2-5*x+6); +[x-1,x+6]$ +factorlist(x^3-1); +[x-1,x^2+x+1]$ + +cartesian_product({1, 2}, {3, 4}); +{[1, 3], [1, 4], [2, 3], [2, 4]}$ diff --git a/stack/2024060300/maxima/rtest_assessment_simpfalse.mac b/stack/2024060300/maxima/rtest_assessment_simpfalse.mac new file mode 100644 index 0000000..e3728ac --- /dev/null +++ b/stack/2024060300/maxima/rtest_assessment_simpfalse.mac @@ -0,0 +1,125 @@ +scientific_notation(123.456); +1.23456*10^2$ + +factorp(x); +true$ +factorp(2); +true$ +factorp(4); +false$ +factorp(2^2); +true$ +factorp(2^2*x^3); +true$ +factorp(x^2); +true$ +factorp(y^2*x^2); +true$ +factorp((y*x)^2); +true$ +factorp((x-1)*(1+x)); +true$ +factorp((x-1)^2); +true$ +factorp((1-x)^2); +true$ +factorp(2*(x-1)); +true$ +factorp(2*x-1); +true$ +factorp(x^2-1); +false$ +factorp(1+x^2); +true$ +factorp((x-1)*(1+x)); +true$ +factorp((x-%i)*(%i+x)); +true$ +factorp(4*(x-1/2)^2); +false$ + +commonfaclist([12,15]); +3$ +commonfaclist([12,15,60,9]); +3$ +commonfaclist([x^2-1,x^3-1]); +x-1$ +commonfaclist([x = 6,8]); +1$ + +lowesttermsp(x); +true$ +lowesttermsp(0.5); +true$ +lowesttermsp(1/2); +true$ +lowesttermsp((-1)/2); +true$ +lowesttermsp(1/(-2)); +true$ +lowesttermsp((-3)/6); +false$ +lowesttermsp((-x)/x^2); +false$ +lowesttermsp(15/3); +false$ +lowesttermsp(3/15); +false$ +lowesttermsp((x-1)/(x^2-1)); +false$ +lowesttermsp(x/(x^2-1)); +true$ +lowesttermsp((2+x)/(x^2-1)); +true$ + +all_lowest_termsex(x); +true$ +all_lowest_termsex(0.5); +true$ +all_lowest_termsex(1/2); +true$ +all_lowest_termsex(2/4); +false$ +all_lowest_termsex(15/3); +false$ +all_lowest_termsex(0.3*x^2+3/15); +false$ +all_lowest_termsex(x/(x^3+x)); +true$ + +list_expression_numbers(0.3*x+1/2); +[1/2,0.3]$ + +exdowncase(X-x); +x-x$ + +StackDISP(-(x-1),""); +"-\\left(x-1\\right)"$ + +buggy_pow( 3*(x+1)^2 ); +3*(x^2+1^2)$ +buggy_pow(x^(a+b)^2); +x^(a^2+b^2)$ +buggy_pow(x^(a+b)^(1/2)); +x^(a^(1/2)+b^(1/2))$ +buggy_pow((x+1)^(a+b)^2); +x^(a^2+b^2)+1^(a^2+b^2)$ +buggy_pow( 3*(x+1)^-1 ); +3*(x^-1+1^-1)$ +buggy_pow( 3*(x+1)^-2 ); +3*(x^-2+1^-2)$ +buggy_pow(sin(sqrt(a+b))); +sin(sqrt(a)+sqrt(b))$ + +mediant(1/2,2/3); +(1+2)/(2+3)$ + +safe_setp({1,2}); +true$ +safe_setp({}); +true$ +safe_setp(set(a,b)); +true$ +safe_setp(1); +false$ + diff --git a/stack/2024060300/maxima/rtest_assessment_simptrue.mac b/stack/2024060300/maxima/rtest_assessment_simptrue.mac new file mode 100644 index 0000000..6f71fbf --- /dev/null +++ b/stack/2024060300/maxima/rtest_assessment_simptrue.mac @@ -0,0 +1,86 @@ +exdowncase(X-x); +0$ + +list_expression_numbers(0.3*x+1/2); +[0.3,1/2]$ + +StackDISP(-(x-1),""); +"1-x"$ + +mediant(1/2,2/3); +3/5$ +mediant(1,1); +1$ +mediant(x/y,z); +(x+z)/(y+1)$ + +comp_square(x^2+2*x+1,x); +(x+1)^2$ +comp_square(3*x^2+6*x+1,x); +3*((x+1)^2-2/3)$ + +stackunits(7,kg/s)*stackunits(2,m)*3*stackunits(2,m); +stackunits(84,(kg*m^2)/s)$ + +stackunits(7,kg/s)*stackunits(2,m)*x; +stackunits(14,(kg*m)/s)*x$ + +y*stackunits(7,kg/s)*stackunits(2,m)*x; +stackunits(14,(kg*m)/s)*x*y$ + +3*stackunits(2,m); +stackunits(6,m)$ + +-3*stackunits(2,m); +stackunits(-6,m)$ + +x-3*stackunits(2,m); +x+stackunits(-6,m)$ + +3*stackunits(4,m)+y-stackunits(6,m); +y+stackunits(6,m)$ + +stack_unit_si_to_si_base(stackunits(10,km)); +stackunits(10000,m)$ + +stack_unit_si_to_si_base(10*km); +10000*m$ + +stack_unit_si_present(10*m/s,km/h); +stackunits(36,km/h)$ + +stack_unit_si_present(5.0*N/(m^2),Pa); +stackunits(5.0,Pa)$ + +stack_unit_si_present(5.0*N/(m^2),[Pa,kPa,cPa]); +stackunits(5.0,Pa)$ + +stack_unit_si_present(500.0*N/(m^2),[Pa,kPa,cPa]); +stackunits(0.5,kPa)$ + +stack_unit_si_present(100.0*N/(m^2),[Pa,kPa,cPa]); +stackunits(100.0,Pa)$ + +stack_unit_si_present(0.0*N/(m^2),[Pa,kPa,cPa]); +stackunits(0.0,Pa)$ + +stack_unit_si_present(0*N/(m^2),[Pa,kPa,cPa]); +stackunits(0,Pa)$ + +stack_unit_si_present(stackunits(345.023,m/s),[km/s,km/h]); +stackunits(0.345023,km/s)$ + +stack_unit_si_present(stackunits(0.023,m/s),[km/s,km/h]); +stackunits(0.0828,km/h)$ + +abs_replace_eq(abs(a) = abs(b)); +(a-b)*(a+b)=0$ + +abs_replace_eq(a^2 = abs(a)*abs(b)); +(a^2-a*b)*(a^2+a*b) = 0$ + +abs_replace_eq(abs(b+a) = abs(b)); +a*(2*b+a)=0$ + +abs_replace_eq(abs(b-a)*abs(b+a) = abs(b)*abs(b-a)); +(a^2-a*b)*(3*a*b+a^2)*((-2*b^2)+a*b+a^2)*(2*b^2+a*b+a^2) = 0$ \ No newline at end of file diff --git a/stack/2024060300/maxima/rtest_experimental.mac b/stack/2024060300/maxima/rtest_experimental.mac new file mode 100644 index 0000000..e69de29 diff --git a/stack/2024060300/maxima/rtest_inequalities.mac b/stack/2024060300/maxima/rtest_inequalities.mac new file mode 100644 index 0000000..2498d27 --- /dev/null +++ b/stack/2024060300/maxima/rtest_inequalities.mac @@ -0,0 +1,238 @@ +make_monic(3*x+6)$ +x+2$ + +ineqprepare(x)$ +x$ + +ineqprepare(x<1)$ +1-x>0$ + +ineqprepare(x^2-9<=0)$ +9-x^2>=0$ + +linear_inequalityp(x>1); +true$ + +linear_inequalityp(x>=1); +true$ + +linear_inequalityp(x=1); +false$ + +linear_inequalityp(x); +false$ + +linear_inequalityp(4*x>1-x)$ +true$ + +linear_inequalityp(x^4+4*x>1-x+x^4)$ +true$ + +linear_inequalityp(4*x>1-y)$ +false$ + +linear_inequalityp(4*x>1-x^2)$ +false$ + +linear_inequalityp(4*x>1-sin(x))$ +false$ + +linear_inequalityp(x-1<=%pi)$ +true$ + +inequality_disp(x-1>0)$ +11); +1%pi); +%pi/2=4); +4<=x$ + +inequality_disp(x<1); +x<1$ + +inequality_disp(4*x<=28); +x<=7$ + +neg_ineq(x>6); +x<6; + +neg_ineq(x>=6); +x<=6; + +neg_ineq(x^2x; + +neg_ineq(x); +x; + +neg_ineq_list([x>1,x>2,x>3],[]); +[x>1,x>2,x>3]$ + +neg_ineq_list([x>1,x>2,x>3],[1]); +[x<1,x>2,x>3]$ + +neg_ineq_list([x>1,x>2,x>3],[1,3]); +[x<1,x>2,x<3]$ + +rev_ineq(x>6); +6=6); +6<=x; + +rev_ineq(x^2x^2; + +rev_ineq(x); +x; + +single_linear_ineq_reduce([x>1,x>1], [max,min])$ +[x>1]$ + +/* Empty interval: not sorted out by this function. */ +single_linear_ineq_reduce([x>1,x<-1], [max,min])$ +[x>1,-1>x]$ + +ineqorder(x^2-1>=5)$ +x^2-6>=0$ + +ineqorder(x^2-1<5*x)$ +-x^2+5*x+1>0$ + +ineq_rem_redundant(x>6 and 1<=x); +x>6$ + +ineq_rem_redundant(x>=6 and 1<=x); +x>=6$ + +ineq_rem_redundant(x>6 and 6<=x); +x>6$ + +ineq_rem_redundant(x<1 and 1>=x); +1>x$ + +ineq_rem_redundant(x>6 or 6<=x); +x>=6$ + +ineq_rem_redundant(x>6 or 1<=x); +x>=1$ + +ineq_rem_redundant(x<2 or 2>=x); +2>=x$ + +ineq_rem_redundant((x>6 or x>1) and x>=4); +x>=4$ + +ineq_rem_redundant((x>6 and 6<=x and y>2 and 66 and y>2$ + +ineq_rem_redundant(11 and %pi>x$ + +ineq_rem_redundant((x>1) %and (x>1))$ +x>1$ + +ineq_rem_redundant((x>1) %and (x>3))$ +x>3$ + +ineq_rem_redundant((x>1) %and (x<3))$ +(3>x) %and (x>1)$ + +ineq_rem_redundant((x>1) %and (x>=1) %and (x>-5))$ +(x>1)$ + +ineq_rem_redundant((x>1) %and (x>=1))$ +(x>1)$ + +ineq_rem_redundant((x>1) %and (x>=1) %and (y>=3) %and (y>2))$ +(x>1) %and (y>=3)$ + +ineq_rem_redundant(((x>1) %and (x>3)) %or (x=1))$ +(x>3) %or (x=1)$ + +/* Join an end point. */ +ineq_rem_redundant((x>1) %or (x=1))$ +(x>=1)$ + +/* Empty interval. */ +ineq_rem_redundant((x>1) %and (x=1))$ +false$ + +/* Whole line. */ +ineq_rem_redundant((x>1) %or (x<=1))$ +true$ + +/* Value included. */ +ineq_rem_redundant((x>1) %or (x=3))$ +x>1$ + +/* Solve inequalities */ + +inequality_factor_solve(x^2>1); +(-1>x) %or (x>1)$ + +inequality_factor_solve(x^2<1); +((-1 > x) %and (x > 1)) %or ((1 > x) %and (x > -1))$ + +inequality_factor_solve(x^2>4); +(-2>x) %or (x>2)$ + +inequality_factor_solve(x^2>-1); +true$ + +inequality_factor_solve(x^2+1<0); +false$ + +inequality_factor_solve(x^2+x>1); +(-(sqrt(5)+1)/2 > x) %or (x > (sqrt(5)-1)/2)$ + +inequality_factor_solve(x^2+x<1); +((sqrt(5)-1)/2 > x) %and (x > -(sqrt(5)+1)/2)$ + +inequality_factor_solve(x^2+x>-1); +true$ + +inequality_factor_solve(x^2>3); +(-sqrt(3) > x) %or (x > sqrt(3))$ + +inequality_factor_solve(2*x^2>1); +(-1/sqrt(2) > x) %or (x > 1/sqrt(2))$ + +inequality_factor_solve(2*x^2<1); +((-1/sqrt(2) > x) %and (x > 1/sqrt(2))) %or ((1/sqrt(2) > x) %and (x > -1/sqrt(2)))$ + +inequality_factor_solve(x^3>8); +x-2>0$ + +inequality_factor_solve(x^3<8); +x-2<0$ + +inequality_factor_solve(x^7>2); +x-2^(1/7) > 0$ + +inequality_factor_solve(x^7<=2); +x-2^(1/7) <= 0$ + +inequality_factor_solve(x^4>16)$ +(-2>x) %or (x>2)$ + +inequality_factor_solve(x>0); +x>0$ + +inequality_factor_solve(x^2>0); +(x > 0) %or (x < 0)$ + +inequality_factor_solve(x^20>0); +(x > 0) %or (x < 0)$ + + + + diff --git a/stack/2024060300/maxima/rtest_intervals.mac b/stack/2024060300/maxima/rtest_intervals.mac new file mode 100644 index 0000000..b27f8fd --- /dev/null +++ b/stack/2024060300/maxima/rtest_intervals.mac @@ -0,0 +1,170 @@ +trivialintervalp(oo(1,1)); +true$ + +trivialintervalp(oo(1,2)); +false$ + +intervalp(oc(a,b)); +true$ + +inintervalp(3,oo(-1,4)); +true$ + +interval_subsetp(oo(1,2), %union(oo(1,2),cc(4,5))); +true$ + +interval_subsetp(%union(oo(1,2),cc(4,5)),%union(oo(1,2),cc(4,5),oc(-5,-2))); +true$ + +interval_containsp(oo(1,2), oo(1,2)); +true$ + +interval_containsp(oo(1,2), %union(oo(-1,2),cc(1,2))); +false$ + +interval_containsp(oo(1,2), %union(oo(-1,2),oo(1,2))); +true$ + +realsetp({1,2}); +true$ + +realsetp({1,a}); +false$ + +interval_count_components({}); +0$ + +interval_count_components(oo(-1,1)); +1$ + +interval_count_components(%union(oo(-1,1),oo(3,5))); +2$ + +interval_count_components(%union(oo(-1,1),oo(3,5),%union({1,2,3},cc(-6,6)))); +6$ + +natural_domain(x+y); +unknown$ + +natural_domain(1); +all$ + +natural_domain(x); +all$ + +natural_domain(1+x); +all$ + +natural_domain(1+abs(x)); +all$ + +natural_domain(1/z); +realset(z,%union(oo(0,inf),oo(-inf,0)))$ + +natural_domain(1/t); +realset(t,%union(oo(0,inf),oo(-inf,0)))$ + +natural_domain(1/x); +realset(x,%union(oo(0,inf),oo(-inf,0)))$ + +natural_domain(1/x^2); +realset(x,%union(oo(0,inf),oo(-inf,0)))$ + +natural_domain(1/(1+x^2)); +all$ + +natural_domain(1+1/x); +realset(x,%union(oo(0,inf),oo(-inf,0)))$ + +natural_domain(1+x^2+1/(x-1)); +realset(x,%union(oo(1,inf),oo(-inf,1)))$ + +natural_domain(1+1/x^2+1/(x-1)); +realset(x,%union(oo(0,1),oo(1,inf),oo(-inf,0)))$ + +natural_domain(1+1/x^2+1/(x+1)); +realset(x,%union(oo(-1,0),oo(0,inf),oo(-inf,-1)))$ + +natural_domain(5*x/(2*x+1)-3/(x+1) = 1); +realset(x,%union(oo(-inf,-1),oo(-1,-1/2),oo(-1/2,inf)))$ + +natural_domain(1+log(x^2-4)); +realset(x,%union(oo(2,inf),oo(-inf,-2)))$ + +natural_domain(ln(x)+ln(-x)); +none$ + +natural_domain(ln(-x^2)); +none$ + +natural_domain(ln(1-x^2)); +realset(x,oo(-1,1))$ + +natural_domain(sqrt(3*x+4) = sqrt(x+2)+2); +realset(x,co(-(4/3),inf))$ + +natural_domain(sqrt(x-7)/(64-x^2)); +realset(x,%union(co(7,8),oo(8,inf)))$ + +natural_domain((64-x^2)/sqrt(x-7)); +realset(x,oo(7,inf))$ + +natural_domain((9*sqrt(x))/2+2/x^2); +realset(x,oo(0,inf))$ + +natural_domain(log(x)/(x-1)); +realset(x,%union(oo(0,1),oo(1,inf)))$ + +stack_single_variable_solver(x^2-4>0); +realset(x,%union(oo(2,inf),oo(-inf,-2)))$ + +stack_single_variable_solver(2*x/abs(x-1)<1); +(1-(2*x)/(x-1) > 0) %or ((2*x)/(x-1)+1 > 0)$ + +stack_single_variable_solver(x>1 or x<2); +all$ + +interval_disjointp(oo(2,inf),oo(-inf,1)); +true$ + +interval_sort(%union(oo(2,3),oo(-2,1))); +[oo(-2,1),oo(2,3)]$ + +interval_tidy([%union(oo(1,4),cc(5,6)),oo(-100,10)]); +oo(-100,10)$ + +interval_complement(oo(1,2)); +%union(oc(-inf,1),co(2,inf))$ + +interval_complement(X); +oo(-inf,inf)$ + +interval_complement({1,2}); +%union(oo(1,2),oo(2,inf),oo(-inf,1))$ + +interval_complement(%union(oo(1,2),oo(2,inf),oo(-inf,1))); +{1,2}$ + +interval_simple_intersect({1,2,3},{2,3,4}); +{2,3}$ + +interval_simple_intersect(oo(-5,3.5),{2,3,4}); +{2,3}$ + +interval_intersect_list([oo(minf,4),oo(-1,10)]); +oo(-1,4)$ + +interval_intersect(%union(oo(0,1),oo(1,inf),oo(-inf,0)),%union(oo(2,inf),oo(-inf,2))); +%union(oo(0,1),oo(1,2), oo(2,inf),oo(-inf,0))$ + +interval_intersect_list([%union(oo(minf,4),cc(5,6)),oo(-1,10)]); +%union(oo(-1,4),cc(5,6))$ + +interval_intersect_list([%union(oo(0,inf),oo(-inf,0)),%union(oo(1,inf),oo(-inf,1)),%union(oo(2,inf),oo(-inf,2)),all]); +%union(oo(0,1),oo(1,2), oo(2,inf),oo(-inf,0))$ + +interval_complement(%union(oo(0,1),oo(2,3),oo(3,inf))); +%union(cc(1,2),oc(-inf,0),{3})$ + +interval_tidy(%union(oo(minf,0),oo(0,3),%union(cc(3,4),oo(-3,-2)))); +%union(oo(minf,0),oc(0,4))$ diff --git a/stack/2024060300/maxima/rtest_noun_simp.mac b/stack/2024060300/maxima/rtest_noun_simp.mac new file mode 100644 index 0000000..39430fe --- /dev/null +++ b/stack/2024060300/maxima/rtest_noun_simp.mac @@ -0,0 +1,208 @@ +zeroAdd(x); +x$ +zeroAdd(0+x); +x$ +zeroAdd(0+0+x); +x$ +zeroAdd(x+0); +x$ +zeroAdd(0*x); +0*x$ +zeroAdd(x*0); +x*0$ +zeroAdd(0^x); +0^x$ +zeroAdd(x^0); +x^0$ + +zeroMul(x); +x$ +zeroMul(x+0); +x+0$ +zeroMul(0*x); +0$ +zeroMul(x*0); +0$ +zeroMul(0^x); +0^x$ +zeroMul(x^0); +x^0$ +zeroMul(0*0*x); +0$ +zeroMul(sin(0*x)); +sin(0*x)$ + +oneMul(x); +x$ +oneMul(x+1); +x+1$ +oneMul(1*x); +x$ +oneMul(x*1); +x$ +oneMul(1^x); +1^x$ +oneMul(x^1); +x^1$ +oneMul(1*1*x); +x$ +oneMul(sin(1*x)); +sin(1*x)$ + + +onePow(1); +1$ +onePow(x^1); +x^1$ +onePow(1^x); +1$ +onePow((1+x)^1); +(1+x)^1$ +onePow(0^1); +0^1$ +onePow(1^0); +1$ + +idPow(1); +1$ +idPow(x^1); +x$ +idPow(1^x); +1^x$ +idPow((1+x)^1); +(1+x)$ +idPow(0^1); +0$ + +zeroPow(1); +1$ +zeroPow(x^0); +x^0$ +zeroPow(0^x); +0$ +zeroPow(0^0); +0^0$ +zeroPow(1+x); +1+x$ +zeroPow(0^(x-x)); +0$ + +zPow(1); +1$ +zPow(x^0); +1$ +zPow(0^x); +0^x$ +zPow(0^0); +0^0$ +zPow(1+x); +1+x$ + +assAdd((a+b)+c); +a+b+c$ +assAdd(a+(b+c)); +a+b+c$ +assAdd((a+b)+(c+d)); +a+b+c+d$ + +assMul((a*b)*c); +a*b*c$ + +comMul(x); +x$ +comMul(1); +1$ +comMul(2*x*3); +2*3*x$ +comMul(2*3.0*%pi); +2*3.0*%pi$ + + +intAddp(3 nounadd UNARY_MINUS nounmul 2); +true$ + +intAdd(1+2); +3$ +intAdd(1+x+2); +3+x$ + +intMul(2*3); +6$ +intMul(2*x*3); +6*x$ +intMul(UNARY_MINUS nounmul 2 nounmul UNARY_MINUS nounmul 6); +12 nounmul UNARY_MINUS nounmul UNARY_MINUS$ + +intPow(2^3); +8$ +intPow(2^x); +2^x$ +intPow(0^0); +0^0; + +intFac(7); +7$ +intFac(18); +2 nounmul 3 nounpow 2$ + +equals_commute_prepare((a/b)/c); +a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))$ +equals_commute_prepare(a/(b/c)); +a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c))$ + +divDivp(a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c)))$ +true$ +divDivp(UNARY_RECIP(UNARY_RECIP(b))); +true$ +divDivp(a nounmul UNARY_RECIP(UNARY_RECIP(b))); +true$ +divDivp(a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))); +false; +divDivp(UNARY_RECIP(b)); +false$ +divDivp(UNARY_RECIP(b nounmul c)); +false$ + +divDiv(UNARY_RECIP(UNARY_RECIP(b))); +b$ +divDiv(a nounmul UNARY_RECIP(UNARY_RECIP(b))); +a nounmul b$ +divDiv(a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c))); +a nounmul c nounmul UNARY_RECIP(b)$ +divDiv(a nounmul UNARY_RECIP(b nounmul B nounmul UNARY_RECIP(c))); +a nounmul c nounmul UNARY_RECIP(b nounmul B)$ +divDiv(A nounmul a nounmul (UNARY_RECIP(b nounmul UNARY_RECIP(c))) nounmul (UNARY_RECIP(B nounmul UNARY_RECIP(C)))); +A nounmul a nounmul (UNARY_RECIP(B nounmul UNARY_RECIP(C))) nounmul c nounmul UNARY_RECIP(b)$ + +divDiv(a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))); +a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))$ +divDiv(UNARY_RECIP(b)); +UNARY_RECIP(b)$ +divDiv(UNARY_RECIP(b nounmul c)); +UNARY_RECIP(b nounmul c)$ + +divCancel(a nounmul b nounmul UNARY_RECIP(a nounmul c)); +b nounmul UNARY_RECIP(c)$ +divCancel(a nounmul UNARY_RECIP(a nounmul c)); +UNARY_RECIP(c)$ +divCancel((a nounadd b) nounmul UNARY_RECIP(a nounadd c)); +(a nounadd b) nounmul UNARY_RECIP(a nounadd c)$ +divCancel(A nounmul (a nounadd b) nounmul UNARY_RECIP(a nounadd b)); +A$ +divCancel(UNARY_MINUS nounmul a nounmul UNARY_RECIP(UNARY_MINUS nounmul b)); +a nounmul UNARY_RECIP(b)$ + +negDist(UNARY_MINUS nounmul x nounmul (UNARY_MINUS nounmul x nounadd 1)); +(UNARY_MINUS nounmul (UNARY_MINUS nounmul x) nounadd UNARY_MINUS nounmul 1) nounmul x$ + +negOrd(a+UNARY_MINUS nounmul b); +a + UNARY_MINUS nounmul b$ + +negOrd(b+UNARY_MINUS nounmul a); +UNARY_MINUS nounmul (UNARY_MINUS nounmul b+a)$ + +negOrd(b+UNARY_MINUS nounmul 3 nounmul a); +b+UNARY_MINUS nounmul 3 nounmul a$ + +negOrd(b+UNARY_MINUS nounmul a+c); +UNARY_MINUS nounmul (UNARY_MINUS nounmul b+a+UNARY_MINUS nounmul c)$ diff --git a/stack/2024060300/maxima/s_test_case.lisp b/stack/2024060300/maxima/s_test_case.lisp new file mode 100644 index 0000000..a2f0b3d --- /dev/null +++ b/stack/2024060300/maxima/s_test_case.lisp @@ -0,0 +1,4 @@ +;; Needed to read in files as textfiles. +(defun readline (stream) (read-line stream nil nil)) + + diff --git a/stack/2024060300/maxima/s_test_case.mac b/stack/2024060300/maxima/s_test_case.mac new file mode 100644 index 0000000..8d3188f --- /dev/null +++ b/stack/2024060300/maxima/s_test_case.mac @@ -0,0 +1,70 @@ +/* Author Chris Sangwin + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* ******************************************************** */ +/* Run STACK packages bespoke maxima unit tests. */ +/* */ +/* To use this in the sandbox try something like */ +/* */ +/* stacklocation:"/var/www/html/m40/question/type/stack"$ */ +/* load("s_test_case.mac"); */ +/* ******************************************************** */ + +print("************ s_test_case results."); + +load("s_test_case.lisp")$ +s_test_case_eval(ex1, ex2):= if(ev(is(ex1=ex2))) then true else sconcat("Expected '", string(ex2), "' but got '", string(ex1), "'."); +s_test_case_eval_simp(ex1, ex2):= if(ev(is(ex1=ex2), simp)) then true else sconcat("Expected '", string(ex2), "' but got '", string(ex1), "'."); + +read_s_test_file(filename) := block([filedescr, stream, oneline, soneline, eof, cnt, s_failing], + /* Load the file to define any functions etc. it contains. */ + load(filename), + /* A list to hold test cases which fail. */ + s_failing:[], + eof: false, + filedescr:file_search(filename), + stream: ?open(filedescr), + while not eof do block( + oneline: ?readline(stream), + soneline: strim(" ", string(oneline)), + if is(slength(soneline)>12) and is(substring(soneline, 1, 13)="\"s_test_case") then block([ex], + ex:parse_string(oneline), + ex:ev(ex, s_test_case=s_test_case_eval, s_test_case_simp=s_test_case_eval_simp), + if stringp(ex) then s_failing:append(s_failing, [[oneline, ex]]) + ), + eof: not(?stringp(oneline)) + ), + if emptyp(s_failing) then print(sconcat("All passed for: ", filename)) else block( + print(sconcat("FAILED in: ", filename)), + print(s_failing) + ) + )$ + +/* Automatically find files in the contrib directory. */ +contrib_files:directory(sconcat(stacklocation, "/stack/maxima/contrib/*.mac"))$ +if emptyp(contrib_files) then print("WARNING: you need to redefine the stacklocation variable correctly to run the tests!"); + +local_files:["geometry.mac"]$ +local_files:map(lambda([ex], sconcat(stacklocation, "/stack/maxima/", ex)), local_files)$ + +all_files:append(local_files, contrib_files)$ + +print("simp:false"); +simp:false; + +/* Load files in the contrib directory and run the tests. */ +while not(emptyp(all_files)) do block( + read_s_test_file(first(all_files)), + all_files:rest(all_files) + ); diff --git a/stack/2024060300/maxima/sandbox.wxm b/stack/2024060300/maxima/sandbox.wxm new file mode 100644 index 0000000..d26ca4f --- /dev/null +++ b/stack/2024060300/maxima/sandbox.wxm @@ -0,0 +1,107 @@ +/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/ +/* [ Created with wxMaxima version 20.12.1 ] */ +/* [wxMaxima: title start ] +STACK Sandbox + [wxMaxima: title end ] */ + + +/* [wxMaxima: comment start ] +This workbook allows you to use the STACK libraries with desktop Maxima. +See https://docs.stack-assessment.org/en/CAS/STACK-Maxima_sandbox +The source code is at https://github.com/maths/moodle-qtype_stack + +1. Clone/downlod the source code of STACK. E.g. https://github.com/maths/moodle-qtype_stack/archive/master.zip +2. Set your operating system with the variable maximaplatform. For Windows set it to "win". +3. Set the stacklocation variable below to the location of the STACK source code you downloaded, e.g. c:/tmp/stackroot +4. Specify a directory for temporary working files, e.g. /tmp or C:/tmp + +[Directories in 2 & 3 can be the same if you don't mind clutter.] + +Note that plots *will not work* in this sandbox. + [wxMaxima: comment end ] */ + + +/* [wxMaxima: input start ] */ +/* For MS platforms you normally need to explicitly set the path. + This assumes you have cloned/downloaed the STACK code into c:/tmp/stackroot + E.g. this file must exist c:/tmp/stackroot/stackmaxima.mac + + Use the forward slash as a directory seperator. + No trailing slash. +*/ +maximaplatform:"win"$ +stacklocation:"c:/tmp/stackroot"$ +stacktmplocation:"c:/tmp"$ + +/*maximaplatform:"linux"$ +stacklocation:"."$ +stacktmplocation:"/tmp"$ +*/ + +/**************************************************** + There should be no need to edit below this line. + + These commands add the location to Maxima's search path. +*/ +file_search_maxima:append( [sconcat(stacklocation, "/stack/maxima/###.{mac,mc}")] , file_search_maxima)$ +file_search_lisp:append( [sconcat(stacklocation, "/stack/maxima/###.{lisp}")] , file_search_lisp)$ +file_search_maxima:append( [sconcat(stacklocation, "/stack/maxima/contrib/###.{mac,mc}")] , file_search_maxima)$ +file_search_lisp:append( [sconcat(stacklocation, "/stack/maxima/contrib/###.{lisp}")] , file_search_lisp)$ +file_search_maxima:append( [sconcat(stacktmplocation, "/###.{mac,mc}")] , file_search_maxima)$ +file_search_lisp:append( [sconcat(stacktmplocation, "/###.{lisp}")] , file_search_lisp)$ + +/* + The following command may be slightly different on your particular server. + There is normally no need to change this. You can see this function on the STACK healtcheck page (moodle admin access only). +*/ +STACK_SETUP(ex):=block( + MAXIMA_VERSION_NUM_EXPECTED:0, + MAXIMA_PLATFORM:maximaplatform, + maxima_tempdir:"", + IMAGE_DIR:"", + PLOT_SIZE:[450,300], + PLOT_TERMINAL:"svg", + PLOT_TERM_OPT:"dynamic font \",11\" linewidth 1.2", + DEL_CMD:"rm", + GNUPLOT_CMD:"gnuplot", + MAXIMA_VERSION_EXPECTED:"default", + URL_BASE:"!ploturl!", + /* Define units available in STACK. */ + stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y], + stack_unit_si_prefix_multiplier:[10^-24, 10^-21, 10^-18, 10^-15, 10^-12, 10^-9, 10^-6, 10^-3, 10^-2, 10^-1, 10, 10^2, 10^3, 10^6, 10^9, 10^12, 10^15, 10^18, 10^21, 10^24], + stack_unit_si_prefix_tex:["\\mathrm{y}", "\\mathrm{z}", "\\mathrm{a}", "\\mathrm{f}", "\\mathrm{p}", "\\mathrm{n}", "\\mu ", "\\mathrm{m}", "\\mathrm{c}", "\\mathrm{d}", "\\mathrm{da}", "\\mathrm{h}", "\\mathrm{k}", "\\mathrm{M}", "\\mathrm{G}", "\\mathrm{T}", "\\mathrm{P}", "\\mathrm{E}", "\\mathrm{Z}", "\\mathrm{Y}"], + stack_unit_si_unit_code:[m, l, L, g, t, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, Wh, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, lx, lm, mol, M, kat, rad, sr, K, VA, eV, Ci], + stack_unit_si_unit_conversions:[m, m^3/1000, m^3/1000, kg/1000, 1000*kg, s, s*3600, 1/s, 1/s, cd, (kg*m)/s^2, kg/(m*s^2), 4.2*J, 4200*J, 1055*J, 1.602177e-19*J, (kg*m^2)/s^2, (kg*m^2)/s^3, 3600*(kg*m^2)/s^2, A, (kg*m^2)/(s^3*A^2), s*A, (kg*m^2)/(s^3*A), (s^4*A^2)/(kg*m^2), (s^3*A^2)/(kg*m^2), (kg*m^2)/(s^2*A), kg/(s^2*A), (kg*m^2)/(s^2*A^2), m^2/s^2, 0.01*Sv, m^2/s^2, cd/m^2, cd, mol, mol/(m^3/1000), mol/s, rad, sr, K, (kg*m^2)/(s^3), 1.602176634E-19*J, Ci], + stack_unit_si_unit_tex:["\\mathrm{m}", "\\mathrm{l}", "\\mathrm{L}", "\\mathrm{g}", "\\mathrm{t}", "\\mathrm{s}", "\\mathrm{h}", "\\mathrm{Hz}", "\\mathrm{Bq}", "\\mathrm{cd}", "\\mathrm{N}", "\\mathrm{Pa}", "\\mathrm{cal}", "\\mathrm{cal}", "\\mathrm{Btu}", "\\mathrm{eV}", "\\mathrm{J}", "\\mathrm{W}", "\\mathrm{Wh}", "\\mathrm{A}", "\\Omega", "\\mathrm{C}", "\\mathrm{V}", "\\mathrm{F}", "\\mathrm{S}", "\\mathrm{Wb}", "\\mathrm{T}", "\\mathrm{H}", "\\mathrm{Gy}", "\\mathrm{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{lm}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}", "\\mathrm{sr}", "\\mathrm{K}", "\\mathrm{VA}", "\\mathrm{eV}", "\\mathrm{Ci}"], + stack_unit_other_unit_code:[min, amu, u, mmHg, bar, ha, cc, gal, mbar, atm, torr, rev, deg, rpm, au, Da, Np, B, dB, day, year, hp, in, ft, yd, mi, lb], + stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 10^4*m^2, m^3*10^(-6), 3.785*l, 10^2*Pa, 101325*Pa, 101325/760*Pa, 2*pi*rad, pi*rad/180, pi*rad/(30*s), 149597870700*m, 1.660539040E-27*kg, Np, B, dB, 86400*s, 3.156e7*s, 746*W, in, 12*in, 36*in, 5280*12*in, 4.4482*N], + stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{ha}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{au}", "\\mathrm{Da}", "\\mathrm{Np}", "\\mathrm{B}", "\\mathrm{dB}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{hp}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{yd}", "\\mathrm{mi}", "\\mathrm{lb}"], + true)$ + +/* Load the main libraries. */ +load("stackmaxima.mac")$ +load("stats")$ +load("distrib")$ +load("descriptive")$ +alias(stack_include_contrib, load)$ + +print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$ +/* [wxMaxima: input end ] */ + + +/* [wxMaxima: input start ] */ + +/* [wxMaxima: input end ] */ + + +/* [wxMaxima: input start ] */ +/* Optional but useful. */ +display2d:true; +simp:false; +debug:true; +/* [wxMaxima: input end ] */ + + + +/* Old versions of Maxima abort on loading files that end in a comment. */ +"Created with wxMaxima 20.12.1"$ diff --git a/stack/2024060300/maxima/stack44.mac b/stack/2024060300/maxima/stack44.mac new file mode 100644 index 0000000..1842d15 --- /dev/null +++ b/stack/2024060300/maxima/stack44.mac @@ -0,0 +1,12 @@ +/*load("sqdnst")*/ +sqrtdenest(a) := + subst("^" = lambda([a, b], + block([discr, max, min], + if evenp(denom(b)) and not atom(a) and inpart(a, 0) = "+" + and (max:max(first(a), rest(a)), + min:a-max, + numberp(discr:sqrt(1-(min/max)^2))) + then (sqrt(max*(1+discr)/2)+signum(min)*sqrt(max*(1-discr)/2))^(2*b) + else a^b)), + a +)$ \ No newline at end of file diff --git a/stack/2024060300/maxima/stack_logic.lisp b/stack/2024060300/maxima/stack_logic.lisp new file mode 100644 index 0000000..dfd2400 --- /dev/null +++ b/stack/2024060300/maxima/stack_logic.lisp @@ -0,0 +1,682 @@ +#| +; logic.mac--Logic algebra package for Maxima CAS. +; Copyright (c) 2008--2009 Alexey Beshenov . +; +; Version 2.11. Last modified 2009-01-07. +; +; logic.mac is free software; you can redistribute it and/or modify it +; under the terms of the GNU Lesser General Public License as published +; by the Free Software Foundation; either version 2.1 of the License, +; or (at your option) any later version. +; +; logic.mac is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with the logic.mac; see the file COPYING. If not, write to the +; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +; Boston, MA 02110-1301, USA. +|# + + +(defvar $logic_mac_version 2.11) + +(defvar use-maxima-logic-operators t) + +(if use-maxima-logic-operators + (progn + (defvar *not-op* 'mnot) + ($texput "not" " \\neg " '$prefix) + (defvar *and-op* 'mand) + ($texput "and" " \\wedge " '$nary) + (defvar *or-op* 'mor) + ($texput "or" " \\vee " '$nary)) + (progn + ($prefix "log-not" 70) + (defvar *not-op* '$log-not) + ($texput "log-not" " \\neg " '$prefix) + ($nary "log-and" 65) + (defvar *and-op* '$log-and) + ($texput "log-and" " \\wedge " '$nary) + ($nary "log-or" 60) + (defvar *or-op* '$log-or) + ($texput "log-or" " \\vee " '$nary))) + +($nary "nand" 62) +(defvar *nand-op* '$nand) +($texput "nand" " \\mid " '$nary) + +($nary "nor" 61) +(defvar *nor-op* '$nor) +($texput "nor" " \\downarrow " '$nary) + +($infix "implies" 59) +(defvar *implies-op* '$implies) +($texput "implies" " \\rightarrow " '$infix) + +($nary "xnor" 58) +(defvar *eq-op* '$xnor) +($texput "xnor" " \leftrightarrow " '$nary) + +($nary "xor" 58) +(defvar *xor-op* '$xor) +($texput "xor" " \\oplus " '$nary) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-maxima-operator (expr) + (if (and (listp expr) expr (listp (car expr)) (car expr)) + (caar expr) + nil)) + +(defun contains-operator (expr op) + (let + ((o (get-maxima-operator expr)) args) + (setf args (if o (cdr expr) nil)) + (if + (eq o op) + t + (member t (mapcar #'(lambda (e) (contains-operator e op)) args))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; maxima versions >=5.43 have an internal cartesian-product function +; incompatible with this function, therefore we only define it if +; previously undefined +(unless (fboundp 'cartesian-product) + (defun cartesian-product (l1 l2) + (if l1 + (append + (mapcar #'(lambda (e) (cons (car l1) e)) l2) + (cartesian-product (cdr l1) l2)) + nil))) + +(defun replicate (n e) + (if (and (integerp n) (>= n 0)) + (if (= n 0) nil (cons e (replicate (1- n) e))) + (error "Invalid arguments to 'replicate'"))) + +(defun zip (l1 l2) + (if (or (not (listp l1)) (not (listp l2)) (/= (length l1) (length l2))) + (error "Invalid arguments to 'zip'")) + (if (null l1) + l1 + (cons (cons (car l1) (car l2)) (zip (cdr l1) (cdr l2))))) + +(defun remove-nth (n l) + (cond + ((or (not (integerp n)) (< n 0)) (error "Invalid argumet to 'remove-nth'")) + ((= n 0) (cdr l)) + (t (cons (car l) (remove-nth (1- n) (cdr l)))))) + +(defun multiset-to-hash (l) + (mapcar + #'(lambda (e) (list e (count e l :test 'equal))) + (remove-duplicates l :test 'equal))) + +(defun hash-to-multiset (h) + (mapcan (lambda (he) (replicate (second he) (first he))) h)) + +(defun cancel-pairs-in-hash (h) + (mapcar (lambda (he) (list (first he) (mod (second he) 2))) h)) + +(defun cancel-pairs (l) + (hash-to-multiset (cancel-pairs-in-hash (multiset-to-hash l)))) + +(defun subst-recursive (expr pairs) + (if pairs + (let ((p (car pairs))) + (subst (cdr p) (car p) (subst-recursive expr (cdr pairs)))) + expr)) + +(defun disjoin-list (pred lst) + (if (null lst) + '(nil nil) + (let ((dl (disjoin-list pred (cdr lst)))) + (if (funcall pred (car lst)) + (list (cons (car lst) (first dl)) (second dl)) + (list (first dl) (cons (car lst) (second dl))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; t or nil +(defun booleanp (x) + (or (eq x t) (eq x nil))) + +(defun logic-sort-comparator (x y) + (cond + ((and (not (booleanp x)) (booleanp y)) t) + ((and (booleanp x) (not (booleanp y))) nil) + ((and (not (listp x)) (listp y)) nil) + ((and (listp x) (not (listp y))) t) + ((and (listp x) (listp y) (< (length x) (length y))) nil) + ((and (listp x) (listp y) (> (length x) (length y))) t) + (t ($orderlessp x y)))) + +(defun sort-symbols (seq) + (sort seq 'logic-sort-comparator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; op (x_1, ..., f(y_1, ..., y_m), ..., x_n) => +; op (x_1, ..., y_1, ..., y_m, ..., x_n) +(defun flatten-nested (args op) + (let + ((nested-exprs nil) + (other nil)) + (loop while args do + (if + (eq (get-maxima-operator (car args)) op) + (setq nested-exprs (cons (car args) nested-exprs)) + (setq other (cons (car args) other))) + (setq args (cdr args))) + (setq + nested-exprs + (mapcar #'(lambda (e) (flatten-nested (cdr e) op)) nested-exprs)) + (if nested-exprs + (append other (apply 'append nested-exprs)) + other))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Logic functions + +; Implication +(defun simp-implies (x y) + (cond + ((eq x nil) t) + ((and (eq x t) (eq y t)) t) + ((and (eq x t) (eq y nil)) nil) + (t (list (list *implies-op* 'simp) x y)))) + +; Webb-operation or Peirce arrow (Quine's dagger, NOR) +(defun simp-nor (&rest args) + (if + (member t args) + (return-from simp-nor nil)) + (setf args (remove-duplicates (remove nil args) :test 'equal)) + (cond + ((null args) t) + ((eq (length args) 1) (simp-not (car args))) + (t (cons (list *nor-op* 'simp) (sort-symbols args))))) + +; Sheffer stroke (alternative denial, NAND) +(defun simp-nand (&rest args) + (if + (member nil args) + (return-from simp-nand t)) + (setf args (remove-duplicates (remove t args) :test 'equal)) + (cond + ((null args) nil) + ((eq (length args) 1) (simp-not (car args))) + (t (cons (list *nand-op* 'simp) (sort-symbols args))))) + +; Equivalence +(defun simp-eq (&rest args) + (setf args (cancel-pairs (remove t (flatten-nested args *eq-op*)))) + (cond + ((null args) t) + ((eq (length args) 1) (car args)) + (t (cons (list *eq-op* 'simp) (sort-symbols args))))) + +; Sum modulo 2 (exclusive or) +(defun simp-xor (&rest args) + (setf args (cancel-pairs (remove nil (flatten-nested args *xor-op*)))) + (cond + ((null args) nil) + ((eq (length args) 1) (car args)) + (t (cons (list *xor-op* 'simp) (sort-symbols args))))) + +; returns t if args = (... x ... not x ...) +; used in simp-and and simp-or +(defun x-not-x (args) + (let + ((neg + (disjoin-list + #'(lambda (e) (eq (get-maxima-operator e) *not-op*)) args))) + (not + (null + (intersection + (mapcar 'cadr (first neg)) (second neg) :test 'equal))))) + +; Logical AND (conjunction) +(defun simp-and (&rest args) + (setf args (flatten-nested args *and-op*)) + (if + (member nil args) + (return-from simp-and nil)) + (setf args (remove-duplicates (remove t args) :test 'equal)) + (cond + ((null args) t) + ((eq (length args) 1) (car args)) + (t + (if (x-not-x args) + nil + (cons (list *and-op* 'simp) (sort-symbols args)))))) + +; Logical OR (disjunction) +(defun simp-or (&rest args) + (setf args (flatten-nested args *or-op*)) + (if + (member t args) + (return-from simp-or t)) + (setf args (remove-duplicates (remove nil args) :test 'equal)) + (cond + ((null args) nil) + ((eq (length args) 1) (car args)) + (t + (if (x-not-x args) + t + (cons (list *or-op* 'simp) (sort-symbols args)))))) + +; Logical NOT (negation) +(defun simp-not (x) + (cond + ((eq (get-maxima-operator x) *not-op*) (cadr x)) + ((eq x nil) t) + ((eq x t) nil) + (t (list (list *not-op* 'simp) x)))) + +(defun apply-op (op args) + (cond + ((eq op *and-op*) (apply 'simp-and args)) + ((eq op *xor-op*) (apply 'simp-xor args)) + ((eq op *not-op*) (apply 'simp-not args)) + ((eq op *or-op*) (apply 'simp-or args)) + ((eq op *nor-op*) (apply 'simp-nor args)) + ((eq op *nand-op*) (apply 'simp-nand args)) + ((eq op *eq-op*) (apply 'simp-eq args)) + ((eq op *implies-op*) (apply 'simp-implies args)) + (t (cons (list op) args)))) + +(defun logic-simp (expr) + (let + ((op (get-maxima-operator expr)) args) + (setf args (if op (mapcar 'logic-simp (cdr expr)) nil)) + (if op + (apply-op op args) + expr))) + +(defun $logic_simp (expr) (logic-simp expr)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +; +; (all-charfuns 1) => ((nil) (t)) +; +; (all-charfuns 2) => ((nil nil) (nil t) (t nil) (t t)) +; +; (all-charfuns 3) => ((nil nil nil) (nil nil t) (nil t nil) (nil t t) +; (t nil nil) (t nil t) (t t nil) (t t t)) +; +; ... +; +|# + +(defun all-charfuns (n) + (if (not (and (integerp n) (>= n 1))) + (error "Invalid argument to 'all-charfuns'")) + (cond + ((= n 1) '((nil) (t))) + (t + (let + ((pre (all-charfuns (1- n)))) + (append + (mapcar (lambda (l) (cons nil l)) pre) + (mapcar (lambda (l) (cons t l)) pre)))))) + +; List of values for all-charfuns, 2^n elements +(defun characteristic-vector (expr &rest args) + (if (null args) + (setf args (list-of-variables expr))) + (if (null args) + (list expr) + (let (vals (n (length args))) + (setf vals (mapcar #'(lambda (l) (zip args l)) (all-charfuns n))) + (mapcar #'(lambda (v) (logic-simp (subst-recursive expr v))) vals)))) + +(defun list-of-variables (expr) + (sort-symbols (cdr ($listofvars expr)))) + +(defun $characteristic_vector (expr &rest args) + (cons '(mlist simp) (apply 'characteristic-vector (cons expr args)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Conversion to the Zhegalkin basis {and, xor} +(defun zhegalkin-basis-substitute (expr) + (let + ((op (get-maxima-operator expr)) args) + (setf args (if op (mapcar 'zhegalkin-basis-substitute (cdr expr)) nil)) + (cond + ; not x => x xor t + ((eq op *not-op*) (simp-xor (car args) t)) + ; x implies y => (x and y) xor x xor t + ((eq op *implies-op*) + (simp-xor (apply 'simp-and args) (first args) t)) + ; x1 nand x2 nand x3 ... nand xn => (x1 and x2 and x3 ... and xn) xor t + ((eq op *nand-op*) (simp-xor (apply 'simp-and args) t)) + ; x nor y => (x or y) xor t + ((eq op *nor-op*) + (simp-xor + (zhegalkin-basis-substitute (simp-or (first args) (second args))) + t)) + ; x or y => (x and y) xor x xor y + ((eq op *or-op*) + (let (zhegform) + (setf zhegform + (simp-xor + (simp-and (first args) (second args)) + (first args) (second args))) + (setf args (cddr args)) + (loop while args do + (setf zhegform + (simp-xor + (simp-and zhegform (car args)) + zhegform + (car args))) + (setf args (cdr args))) + zhegform)) + ; a eq b => a xor b xor t + ; a eq b eq c => a xor b xor c + ; a eq b eq c eq d => a xor b xor c xor d xor t + ; a eq b eq c eq d eq e => a xor b xor c xor d xor e + ; ... + ((eq op *eq-op*) + (apply 'simp-xor + (if (evenp (length args)) (cons t args) args))) + (op (apply-op op args)) + (t expr)))) + +; acts like Maxima "expand" on ordinary polynomial ring, +; but on Zhegalkin polynomials +(defun zhegalkin-basis-expand (expr) + (let + ((op (get-maxima-operator expr)) args) + (setf args (if op (mapcar 'zhegalkin-basis-expand (cdr expr)) nil)) + (cond + ((eq op *and-op*) + (let + ((xor-expression + (find-if + (lambda (e) (eq (get-maxima-operator e) *xor-op*)) + (cdr expr)))) + (if xor-expression + (let + ((xor-args (cdr xor-expression)) + (and-args + (remove xor-expression (cdr expr) :test 'equal))) + (zhegalkin-basis-expand + (apply 'simp-xor + (mapcar + (lambda (e) (apply 'simp-and (cons e and-args))) + xor-args)))) + expr))) + ((eq op *xor-op*) (apply 'simp-xor args)) + (t expr)))) + +(defun $zhegalkin_form (expr) + (zhegalkin-basis-expand (zhegalkin-basis-substitute expr))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun $logic_equiv (expr1 expr2) + (equal + ($zhegalkin_form expr1) + ($zhegalkin_form expr2))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun subst-not (expr) + (let + ((op (get-maxima-operator expr))) + (if op + (cons (list op) (mapcar 'subst-not (cdr expr))) + (simp-not expr)))) + +; f^* (x_1, ..., x_n) = not f (not x_1, ..., not x_n) +(defun $dual_function (expr) + (logic-simp (simp-not (subst-not expr)))) + +; f = f^* +(defun $self_dual (expr) + ($logic_equiv expr ($dual_function expr))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun closed-under (expr x) + (let + (val n (args (list-of-variables expr))) + (setf n (length args)) + (setf val (zip args (replicate n x))) + (eq (logic-simp (subst-recursive expr val)) x))) + +; f (nil, ..., nil) = nil +(defun $closed_under_f (expr) + (closed-under expr nil)) + +; f (t, ..., t) = t +(defun $closed_under_t (expr) + (closed-under expr t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun $monotonic (expr &rest args) + (let + (prev-value (charvec (apply 'characteristic-vector (cons expr args)))) + (if charvec + (progn + (setf prev-value (car charvec)) + (setf charvec (cdr charvec)) + (loop while charvec do + (if + (and + (eq (car charvec) nil) + (eq prev-value t)) + (return-from $monotonic nil)) + (setf prev-value (car charvec)) + (setf charvec (cdr charvec))) + t) + t))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun $linear (expr) + (not (contains-operator ($zhegalkin_form expr) *and-op*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Post's theorem + +(defun post-table (&rest expressions) + (mapcar + (lambda (fn) (mapcar fn expressions)) + '($self_dual $closed_under_f $closed_under_t $linear $monotonic))) + +(defun functionally-complete (table) + (if + (null table) + (return-from functionally-complete nil)) + (loop while table do + (if + (not (member nil (car table))) + (return-from functionally-complete nil)) + (setf table (cdr table))) + t) + +(defun $functionally_complete (&rest expressions) + (functionally-complete (apply 'post-table expressions))) + +; Basis is a complete system without redundant functions +(defun $logic_basis (&rest expressions) + (let + ((table (apply 'post-table expressions)) + (n (length expressions))) + (if (functionally-complete table) + (if (= n 1) + (return-from $logic_basis t)) + (return-from $logic_basis nil)) + (loop for i from 0 to (1- n) do + (if + (functionally-complete + (mapcar (lambda (e) (remove-nth i e)) table)) + (return-from $logic_basis nil))) + t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Logic differentiation + +#| +; +; dy +; (1) --- = false +; dx +; +; where y is a variable which not depends on x. +; +; +; dx +; (2) --- = true +; dx +; +; +; d +; (3) --- [x and ... and x ] = x and x ... and x +; dx 1 n 2 3 n +; 1 +; +; +; d df dg +; (4) -- [g xor f] = -- xor -- +; dx dx dx +; +; +; TO-DO: higher orders / mixed +; +|# + +(defun diff-zhegalkin-form (expr x) + (let ((op (get-maxima-operator expr))) + (cond + ((null op) (eq expr x)) + ((eq op *xor-op*) + (apply + 'simp-xor + (mapcar #'(lambda (e) (diff-zhegalkin-form e x)) (cdr expr)))) + ((eq op *and-op*) + (let ((args (cdr expr))) + (if (member x args) (apply 'simp-and (remove x args)) nil))) + (t (error "Not a Zhegalkin form in diff-zhegalkin-form: '~s'" expr))))) + +(defun $logic_diff (expr x) + (diff-zhegalkin-form ($zhegalkin_form expr) x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Coversion to the Boolean basis {and, or, not} +(defun boolean-basis-substitute (expr) + (let + ((op (get-maxima-operator expr)) args) + (setf args (if op (mapcar 'boolean-basis-substitute (cdr expr)) nil)) + (cond + ; x implies y => (not x) or y + ((eq op *implies-op*) (simp-or (simp-not (first args)) (second args))) + ; x1 nand ... nand xn => not (x1 and ... and xn) + ((eq op *nand-op*) (simp-not (apply 'simp-and args))) + ; x1 nor ... not xn => not (x1 or ... or xn) + ((eq op *nor-op*) (simp-not (apply 'simp-or args))) + ; x eq b => ((not x) or y) and ((not y) or x) + ((eq op *eq-op*) + (let (boolform) + (setf boolform + (simp-and + (simp-or (simp-not (first args)) (second args)) + (simp-or (simp-not (second args)) (first args)))) + (setf args (cddr args)) + (loop while args do + (setf boolform + (simp-and + (simp-or (simp-not boolform) (car args)) + (simp-or (simp-not (car args)) boolform))) + (setf args (cdr args))) + boolform)) + ; x xor y => ((not x) and y) or ((not y) and x) + ((eq op *xor-op*) + (let (boolform) + (setf boolform + (simp-or + (simp-and (simp-not (first args)) (second args)) + (simp-and (simp-not (second args)) (first args)))) + (setf args (cddr args)) + (loop while args do + (setf boolform + (simp-or + (simp-and (simp-not boolform) (car args)) + (simp-and (simp-not (car args)) boolform))) + (setf args (cdr args))) + boolform)) + (op (apply-op op args)) + (t expr)))) + +(defun $boolean_form (expr) + (boolean-basis-substitute expr)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; De Morgan's rules +(defun $demorgan (expr) + (let + ((op (get-maxima-operator expr)) args) + (setf args (if op (mapcar '$demorgan (cdr expr)) nil)) + (cond + ((eq op *not-op*) + (let ((op-op (get-maxima-operator (car args)))) + (cond + ((eq op-op *and-op*) (apply 'simp-or (mapcar 'simp-not (cdar args)))) + ((eq op-op *or-op*) (apply 'simp-and (mapcar 'simp-not (cdar args)))) + (t (apply 'simp-not args))))) + ((null op) expr) + (t (apply-op op args))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Perfect disjunctive normal forms + +(defun elementary-conjunct-disjunct (vars-vals b) + (if (null vars-vals) + nil + (cons + (if (eq (cdar vars-vals) b) + (caar vars-vals) + (list (list *not-op* 'simp) (caar vars-vals))) + (elementary-conjunct-disjunct (cdr vars-vals) b)))) + +(defun pdnf-pcnf (expr b) + (let ((args (list-of-variables expr))) + (if (null args) + expr + (let (vals (n (length args)) (result nil)) + (setf vals (mapcar #'(lambda (l) (zip args l)) (all-charfuns n))) + (loop while vals do + (if (eq (logic-simp (subst-recursive expr (car vals))) b) + (setf result + (cons + (apply (if b 'simp-and 'simp-or) + (elementary-conjunct-disjunct (car vals) b)) + result))) + (setf vals (cdr vals))) + (apply (if b 'simp-or 'simp-and) result))))) + +; Perfect disjunctive normal form +(defun $pdnf (expr) + (pdnf-pcnf expr t)) + +; Perfect conjunctive normal form +(defun $pcnf (expr) + (pdnf-pcnf expr nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/stack/2024060300/maxima/stackmaxima.mac b/stack/2024060300/maxima/stackmaxima.mac new file mode 100644 index 0000000..c508ece --- /dev/null +++ b/stack/2024060300/maxima/stackmaxima.mac @@ -0,0 +1,3337 @@ +/* Author Chris Sangwin + Loughborough University + Copyright (C) 2014 Chris Sangwin + University of Edinburgh + Copyright (C) 2017 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* ********************************** */ +/* Global variable options */ +/* ********************************** */ + +stack_reset(not_used) := block( + if featurep(all, constant) then remove(all, constant), + kill(allbut [functions]), + kill(trigsimp), + /* Very unlikley the function psi will be needed for assessment and it breaks the session + when it is used as a variable. */ + kill(psi), + simpsum: true, + negdistrib: true, /* When negdistrib is true, -1 distributes over an expression. E.g., -(x + y) becomes - y - x. */ + display2d: false, + linel: 2047, + nolabels: true, + logabs: true, + exptdispflag: true, + linsolvewarn: false, + ratprint: false, + factor_max_degree_print_warning:false, + /* Suppress warnings printed by mtell, e.g. by solve, rat and other functions. */ + stack_mtell_quiet:false, + fpprintprec: 12, /* Print only 12 digits. */ + fpprec: 20, /* Work with 20 digits. */ + %E_TO_NUMLOG: true, /* "r" some rational number, and "x" some expression, %E^(r*LOG(x)) => x^r .*/ + /* Synonyms to help students */ + e: exp(1), + pi: %pi, + Pi: %pi, + PI: %pi, + pi() := %pi, /* Why does Excel do this?! */ + /* Display of matrixes */ + lmxchar: "[", + /* Sets up randomization, using Maxima's internal random command. */ + stack_randseed(10000), + + mminusbp120(true), + + /*Reload local settings*/ + STACK_SETUP(true), + + MAXIMA_VERSION_STR: ?\*autoconf\-version\*, + MAXIMA_VERSION: map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp)), + /* We need the "if" statement below, because versions compiled from source give erroneous results. */ + MAXIMA_VERSION_NUM: float(MAXIMA_VERSION[2]+(if is(length(MAXIMA_VERSION)>2) + then (if is(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 else 0) else 0)), + + OPT_OUTPUT: "LaTeX", + PLOT_TAGS: true, + + /* Records the number of the plot. */ + STACK_PLOT_UNIQUE_NUMBER: 0, + + true +)$ + +/* Sometimes we need i,j,e etc to be *symbols*, not values. */ +stack_reset_vars(ex) := block(kill(i, j, e, pi, Pi, PI)); + +/* Execute this command to ensure values have been set. */ +stack_reset(true); + +/* Make sure this is at least defined. */ +debug:false; + +/* TO-DO: remove this from install process. */ +/* ********************************************************************* */ +/* Evaluate variables are return errors, display, and content forms. */ +/* ********************************************************************* */ + +/* This function executes ex, which is assumed to be a stack expression */ +/* which is surrounded by errcatch. Hence we end up with a list. */ +cte(var, ex) := block([str], + print("], key = ["), + print(var), + print("]"), + if ex = [] then block( + ex:STACKERROR, + print(", value = [], display = []") + ) + else block( + print(", value = ["), + print(string(ex[1])), + print("], dispvalue = ["), + print(stack_dispvalue(ex[1])), + print("], display = ["), + print(stack_disp(ex[1], "")), + print("]"), + ex:ex[1] + ), + print("], "), + return(ex) +)$ + +/* This function strips out functions to leave only things in the value which might be typed in. */ +stack_dispvalue(ex) := block( + if not(stack_disp_control_structurep(ex)) then block( + if safe_op(ex)="%union" and is(length(args(ex))=1) then + ex: first(args(ex)), + ex: make_displaydpvalue(ex), + ex: make_displayscivalue(ex), + ex: subst("*", stackunits, ex), + ex: unary_minus_sort(ex), + ex: destackvector(ex)), + return(string(ex)) +)$ + +/* ********************************** */ +/* Load contributed packages */ +/* ********************************** */ + +load("functs"); +/* Not yet testsed: load("vect"); */ + +/* Load the logic package, but remove the "eq" infix operator which conflicts with too many existing things. */ +/* We've edited the logic package which over writes the eq operator as xnor. */ +load("stack_logic.lisp"); + +/* We don't want to allow people to put boxes round things. */ +box(ex) := ex; + +/* Although this works well in MAXIMA, |'s are not allowed in STACK */ +/* The heuristics to catch the various errors do not work, since | is symmetrical */ +matchfix("|", "|"); +"|"([a]) := apply(abs, a); + +/* Does not quite work yet ..... */ +/* load("noninteractive.mac"); */ + +/* ********************************** */ +/* Load STACK packages */ +/* ********************************** */ + +/* This must come before stacktex.lisp as the latter relies on compiled functions in utils.mac. */ +load("utils.mac"); +load("errortostring.lisp"); + +load("assessment.mac"); +load("validator.mac"); +load("noun_simp.mac"); +load("inequalities.mac"); +load("intervals.mac"); +load("geometry.mac"); +load("proof.mac"); +load("stackunits.mac"); +load("stacktex.lisp"); +load("stackstrings.mac"); +load("fboundp.mac"); +load("functs"); + +load("stacktex.lisp"); +/* Ensure back compatability with versions before 5.41.0. */ +if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp"); +if is(MAXIMA_VERSION_NUM<44.0) then load("stack44.mac"); + +/* This file is a modified core Maxima function with local variable name clashes fixed. */ +load("trigrat.lisp"); +load("trigtools"); +load("diag"); + +load("sregex"); +load("numericaltest.mac"); + +load("local.mac"); + +/* Breaks on older versions of Maxima. */ +if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$ + +texput(QMCHAR, "\\color{red}{?}"); +texput(theta, "\\theta"); + +int([ex]) := apply(integrate, ex); /* Allows integrate to be called with int(). Avoid alias to allow nouns to work. */ +alias(cosec,csc); /* Corresponds to current student expectations. */ +alias(cosech,csch); /* Corresponds to current student expectations. */ + +alias(sgn,signum); /* Corresponds to current student expectations. */ +texput(signum, "\\mathrm{sgn}"); + +declare ("#", commutative); + +simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */ +degree(ex, v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */ + + +make_complexJ(OPT_COMPLEXJ) := block( + if OPT_COMPLEXJ = "i" then + (i:%i,texput(%i,"\\mathrm{i}")) + else if OPT_COMPLEXJ = "j" then + (%j:%i,j:%i,texput(%i,"\\mathrm{j}")) + else if OPT_COMPLEXJ = "symi" then + (texput(%i,"\\mathrm{i}")) + else if OPT_COMPLEXJ = "symj" then + (texput(%i,"\\mathrm{j}")) + else true +)$ + +/* Choose the symbol for the multiplication sign. */ +make_multsgn(OPT_MULTSGN) := block( + if OPT_MULTSGN = "cross" then texput("*", "\\times ", nary), + if OPT_MULTSGN = "dot" then texput("*", "\\cdot ", nary), + if OPT_MULTSGN = "onum" then texput("*", multsgnonlyfornumbers), + if OPT_MULTSGN = "blank" then texput("*", "\\, ", nary) +); + +/* This only prints a multiplication sign for numbers. */ +/* Thanks to Evgeniy Silchenko. */ +texput(multsgnonlyfornumberssym, "\\times")$ + +multsgnonlyfornumbers(e) := block([arglist, resstr, a, lastisnum, isnum, multsgn, str], + arglist: args(e), + a: pop(arglist), + resstr: if ev(is(safe_op(a) = "-" or (real_numberp(a) and is(a<0)))=true, simp) then sconcat("\\left(", tex1(a), "\\right)") + else if (atom(a) or is(length(args(a))=1) or safe_op(a) = "^") then tex1(a) + else sconcat("\\left(", tex1(a), "\\right)"), + lastisnum: numberp(a), + for a in arglist do ( + isnum: numberp(a), + multsgn: if ev(is(lastisnum and isnum)=true, simp) then tex1(multsgnonlyfornumberssym) else "\\,", + str: if ev(is(safe_op(a) = "-" or (real_numberp(a) and is(a<0)))=true, simp) then sconcat("\\left(", tex1(a), "\\right)") + else if ev(is(atom(a) or is(length(args(a))=1) or safe_op(a) = "^")=true, simp) then tex1(a) + else sconcat("\\left(", tex1(a), "\\right)"), + resstr: sconcat(resstr, multsgn, " ", str), + lastisnum: isnum + ), + resstr +)$ + +make_logic(OPT_LOGIC) := block( + if OPT_LOGIC = "lang" then block( + texput("and", "\\,{\\text{ !AND! }}\\, ", nary), + texput("nounand", "\\,{\\text{ !AND! }}\\, ", nary), + texput("or", "\\,{\\text{ !OR! }}\\, ", nary), + texput("nounor", "\\,{\\text{ !OR! }}\\, ", nary), + texput("nand", "\\,{\\text{ !NAND! }}\\, ", nary), + texput("nor", "\\,{\\text{ !NOR! }}\\, ", nary), + texput("xor", "\\,{\\text{ !XOR! }}\\, ", nary), + texput("xnor", "\\,{\\text{ !XNOR! }}\\, ", nary), + texput("implies", "\\,{\\text{ !IMPLIES! }}\\, ", nary), + texput("not", "{\\rm !NOT!}", prefix), + texput("nounnot", "{\\rm !NOT!}", prefix) + ), + if OPT_LOGIC = "symbol" then block( + texput("and", "\\land ", nary), + texput("nounand", "\\land ", nary), + texput("or", "\\lor ", nary), + texput("nounor", "\\lor ", nary), + texput("nand", "\\overline{\\land}", nary), + texput("nor", "\\underline{\\lor}", nary), + texput("xor", "\\oplus ", nary), + texput("xnor", "\\leftrightarrow ", nary), + texput("implies", "\\rightarrow ", nary), + texput("not", "\\neg ", prefix), + texput("nounnot", "\\neg ", prefix) + ), + return(true) +)$ + +make_arccos(OPT_ACOS) := block( + if OPT_ACOS = "cos-1" then block( + ?tex\-setup(?cdr([?%asin, "\\sin^{-1}"])), + ?tex\-setup(?cdr([?%acos, "\\cos^{-1}"])), + ?tex\-setup(?cdr([?%atan, "{\\tan^{-1}}"])), + ?tex\-setup(?cdr([?%asec, "{\\rm sec}^{-1}"])), + ?tex\-setup(?cdr([?%acsc, "{\\rm csc}^{-1}"])), + ?tex\-setup(?cdr([?%acot, "{\\rm cot}^{-1}"])), + ?tex\-setup(?cdr([?%asinh, "{\\rm sinh}^{-1}"])), + ?tex\-setup(?cdr([?%acosh, "{\\rm cosh}^{-1}"])), + ?tex\-setup(?cdr([?%atanh, "{\\rm tanh}^{-1}"])), + ?tex\-setup(?cdr([?%asech, "{\\rm sech}^{-1}"])), + ?tex\-setup(?cdr([?%acsch, "{\\rm csch}^{-1}"])), + ?tex\-setup(?cdr([?%acoth, "{\\rm coth}^{-1}"])) + ), + if OPT_ACOS = "arccos" then block( + ?tex\-setup(?cdr([?%asin, "\\arcsin "])), + ?tex\-setup(?cdr([?%acos, "\\arccos "])), + ?tex\-setup(?cdr([?%atan, "\\arctan "])), + ?tex\-setup(?cdr([?%asec, "{\\rm arcsec}"])), + ?tex\-setup(?cdr([?%acsc, "{\\rm arccsc}"])), + ?tex\-setup(?cdr([?%acot, "{\\rm arccot}"])), + ?tex\-setup(?cdr([?%asinh, "{\\rm arcsinh}"])), + ?tex\-setup(?cdr([?%acosh, "{\\rm arccosh}"])), + ?tex\-setup(?cdr([?%atanh, "{\\rm arctanh}"])), + ?tex\-setup(?cdr([?%asech, "{\\rm arcsech}"])), + ?tex\-setup(?cdr([?%acsch, "{\\rm arccsch}"])), + ?tex\-setup(?cdr([?%acoth, "{\\rm arccoth}"])) + ), + if OPT_ACOS = "acos" then block( + ?tex\-setup(?cdr([?%asin, "{\\rm asin}"])), + ?tex\-setup(?cdr([?%acos, "{\\rm acos}"])), + ?tex\-setup(?cdr([?%atan, "{\\rm atan}"])), + ?tex\-setup(?cdr([?%asec, "{\\rm asec}"])), + ?tex\-setup(?cdr([?%acsc, "{\\rm acsc}"])), + ?tex\-setup(?cdr([?%acot, "{\\rm acot}"])), + ?tex\-setup(?cdr([?%asinh, "{\\rm asinh}"])), + ?tex\-setup(?cdr([?%acosh, "{\\rm acosh}"])), + ?tex\-setup(?cdr([?%atanh, "{\\rm atanh}"])), + ?tex\-setup(?cdr([?%asech, "{\\rm asech}"])), + ?tex\-setup(?cdr([?%acsch, "{\\rm acsch}"])), + ?tex\-setup(?cdr([?%acoth, "{\\rm acoth}"])) + ), + if OPT_ACOS = "arccos-arcosh" then block( + ?tex\-setup(?cdr([?%asin, "\\arcsin "])), + ?tex\-setup(?cdr([?%acos, "\\arccos "])), + ?tex\-setup(?cdr([?%atan, "\\arctan "])), + ?tex\-setup(?cdr([?%asec, "{\\rm arcsec}"])), + ?tex\-setup(?cdr([?%acsc, "{\\rm arccsc}"])), + ?tex\-setup(?cdr([?%acot, "{\\rm arccot}"])), + ?tex\-setup(?cdr([?%asinh, "{\\rm arsinh}"])), + ?tex\-setup(?cdr([?%acosh, "{\\rm arcosh}"])), + ?tex\-setup(?cdr([?%atanh, "{\\rm artanh}"])), + ?tex\-setup(?cdr([?%asech, "{\\rm arsech}"])), + ?tex\-setup(?cdr([?%acsch, "{\\rm arcsch}"])), + ?tex\-setup(?cdr([?%acoth, "{\\rm arcoth}"])) + ) +)$ + +/* Fine tune the display of fractions between inline and displayed. */ +stackfractionsinline(e) := block ([a, b], + [a, b]: args(e), + /* We need to be more careful about when we have brackets around expressions in inline fractions. */ + if (atom(b) or safe_op(b) = "^") then return(concat("{", tex1(a), "}/{", tex1(b), "}")), + if is(length(args(b))=1) then return(concat("{", tex1(a), "}/{", tex1(b), "}")), + concat("{", tex1(a), "}/{\\left(", tex1(b), "\\right)}") +)$ + +stackfractionsdisplay(e) := block ([a, b], + [a, b]: args (e), + concat("\\frac{", tex1(a), "}{", tex1(b), "}") +)$ + +stack_disp_fractions(ex) := block( + if is(ex="i") then + ev(texput("/", stackfractionsinline),simp) + else + ev(texput("/", stackfractionsdisplay),simp) +)$ + +/* This is needed to tweak the display of noun derivatives. */ +nary("blankmult", 0, 0); +texput("blankmult", " ", nary); + +/* ****************************************************** */ +/* Unit testing of questions */ +/* ****************************************************** */ +/* This function allows a teacher to add unit tests to */ +/* individual questions. At the end of the question */ +/* variables, or in the feedback variables, particular */ +/* values can throw runtime errors. */ +/* ****************************************************** */ +s_assert(ex1, ex2):= if is(ex1=ex2) then true else + error("s_assert: STACK expected '", string(ex2), "' but was given '", string(ex1), "'."); + +/* ****************************************************** */ +/* Random numbers */ +/* ****************************************************** */ +/* http://random.mat.sbg.ac.at/generators/ */ +/* ****************************************************** */ +/* Developer warning: random functions determining */ +/* whether a question is a singleton. */ +/* When adding new "random" functions, also update */ +/* question->has_random_variants() */ +/* ****************************************************** */ + +/* Change the random seed */ +stack_randseed(s) := block(RANDOM_STATE:make_random_state(s), errcatch(ev(set_random_state(RANDOM_STATE), simp)))$ + +/* The top level function */ +rand(ex) := block( + if setp(ex) then ex:listify(ex), + ex:ev(ex, simp), + if (integerp(ex)) then return(random(ex)), + if (floatnump(ex)) then return(random(ex)), + if (matrixp(ex)) then return(matrixmap(random, ex)), + if (listp(ex)) then return(randlist(ex)) +)$ + +/* Allow zero as an argument to random. */ +rand_zero(ex):= block( + if not(integerp(ex)) then error("rand_zero expects its argument to be an integer."), + if is(ex<0) then error("rand_zero expects its argument to be non-negative."), + if is(ex=0) then return(0), + return(rand(ex)) +)$ + +randlist(ex) := block( + if (length(ex) > 0) then return(ex[ev(1+random(length(ex)),simp)]) else return([]) +)$ + +/* Returns a random number from the set {lower, lower+step, lower+2*step, ... , final}. */ +/* Jarno Ruokokoski, 29/10/2009 */ +rand_with_step(lower, upper, step_parameter) := block([temprand], + temprand: rand(floor((upper-lower)/step_parameter)+1), + return(ev(step_parameter*temprand+lower, simp)) +)$ + +/* Returns a random integer from the set [lower,upper] such that it cannot be any value in list. This list can include values which are also random variables, for example, generated by rand_with_step. */ +/* Jarno Ruokokoski, 29/10/2009 */ +rand_with_prohib(lower, upper, list) := block([currents, retVal, kloop], + currents: ev((makelist(i, i, lower, upper)), simp), + for kloop:1 thru length(list) do block( + currents: simplify(delete(list[ev(kloop, simp)], currents)) + ), + retVal: rand(currents), + return(retVal) +)$ + +/* CJS, 11/6/2021 */ +rand_selection_with_replacement(ex, n) := block( + if setp(ex) then ex:listify(ex), + if not(listp(ex)) then ( + error("rand_selection_with_replacement error: first argument must be a list."), + return([]) + ), + if not(integerp(n)) then ( + error("rand_selection_with_replacement error: second argument must be an integer."), + return([]) + ), + return(rand_selection_with_replacement_fun(ex, n)) +)$ + +/* We can't use makelist here because of the simp:false requirement. +rand_selection_with_replacement_fun(ex, n) := makelist(rand(ex), k, 1, n)$ +*/ +rand_selection_with_replacement_fun(ex, n) := block( + if is(n<=0) then return([]), + append([rand(ex)], rand_selection_with_replacement_fun(ex, ev(n-1,simp))) +)$ + +/* Make a random selection of n different items from the list, or set ex. */ +/* CJS, 7/6/2016 */ +rand_selection(ex, n) := block( + if setp(ex) then ex:listify(ex), + if not(listp(ex)) then ( + error("rand_selection error: first argument must be a list or set."), + return([]) + ), + if not(integerp(n)) then ( + error("rand_selection error: second argument must be an integer."), + return([]) + ), + if is(n>length(ex)) then ( + error("rand_selection error: insuffient elements in the list/set."), + return([]) + ), + return(rand_selection_fun(ex, n)) +)$ + +rand_selection_fun(exin, n) := block([k], + if is(n=0) then return([]), + k: ev(rand(length(exin))+1, simp), + cons(exin[k], rand_selection_fun(list_remove(exin, k), ev(n-1, simp))) +)$ + +/* Remove the n'th element from the list ex. */ +list_remove(ex, n) := block([k, l], + if is(n>length(ex)) or is (n<1) then return(ex), + /* Using simplification make a list of indices, then without simplification use them. */ + l: ev(append(makelist(k, k, 1, n-1), makelist(k, k, n+1, length(ex))), simp), + makelist(ex[k], k, l) +)$ + +/********************************************/ +/*********** Random set generation *********/ +/********************************************/ +/* Could be implemented with rand_selection but would require two conversions + * between sets and lists*/ +random_subset(u):= + disjoin(false, map(lambda([x], if rand(2)=0 then x), u)); + +random_subset_n(u,n) := + setify(rand_selection(listify(u),n)); + +/* random non-empty subset */ +random_ne_subset(u) := random_subset_n(u, rand(cardinality(u))+1); + + +/* Create a number in a random range. */ +rand_range([ex]) := block( + if (length(ex)<2 or length(ex)>3) then error("rand_range must have 2 or 3 arguments."), + if not(integerp(ex[1])) then error("rand_range expects its first argument to be an integer."), + if not(integerp(ex[2])) then error("rand_range expects its second argument to be an integer."), + if is(length(ex)=2) then return(ev(ex[1]+rand_zero(ex[2]-ex[1]), simp)), + if not(integerp(ex[3])) then error("rand_range expects its third argument to be an integer."), + return(ev(ex[1]+ex[3]*rand_zero(floor((ex[2]-ex[1])/ex[3])), simp)) +)$ + +/* Helper function for constructing MCQ arrays. */ +multiselqn(corbase, numcor, wrongbase, numwrong):=block([ta1, ta2, ta, version], + if not(listp(corbase)) then error("multiselqn: first argument must be a list."), + if not(listp(wrongbase)) then error("multiselqn: third argument must be a list."), + if not(integerp(numcor)) then error("multiselqn: second argument must be an integer."), + if not(integerp(numwrong)) then error("multiselqn: fourth argument must be an integer."), + if length(corbase)4 then dispflag:fifth(exs), + if not(listp(corbase)) then error("multiselqnalpha: first argument must be a list."), + if not(listp(wrongbase)) then error("multiselqnalpha: third argument must be a list."), + if not(integerp(numcor)) then error("multiselqnalpha: second argument must be an integer."), + if not(integerp(numwrong)) then error("multiselqnalpha: fourth argument must be an integer."), + if length(corbase)", ex1, " ", + if stringp(ex2[1]) then ex2[1] else stack_disp(ex2[1], dispflag))]), talab, ta3), + version: map(first, ta3), + return([ta, version]) +)$ + +/* Helper function for constructing MCQ arrays where the values should not be shown to students. */ +multiselqndisplay(corbase, numcor, wrongbase, numwrong):=block([ta1, ta2, ta, version], + if not(listp(corbase)) then error("multiselqndisplay: first argument must be a list."), + if not(listp(wrongbase)) then error("multiselqndisplay: third argument must be a list."), + if not(integerp(numcor)) then error("multiselqndisplay: second argument must be an integer."), + if not(integerp(numwrong)) then error("multiselqndisplay: fourth argument must be an integer."), + if length(corbase)=2)), ta)) then error("mcq_correct: all list elements must be lists of length at least 2, but was passed: ", string(ta)), + maplist(first, sublist(ta, lambda([ex], second(ex)))) +)$ + +mcq_incorrect(ta):=block( + if not(listp(ta)) then error("mcq_incorrect: first argument must be a list, but was passed: ", string(ta)), + if not(all_listp(listp, ta)) then error("mcq_incorrect: all list elements must be lists, but was passed: ", string(ta)), + if not(all_listp(lambda([ex], is(length(ex)>=2)), ta)) then error("mcq_incorrect: all list elements must be lists of length at least 2, but was passed: ", string(ta)), + maplist(first, sublist(ta, lambda([ex], not(second(ex))))) +)$ + +/* ********************************** */ +/* Statistics function */ +/* ********************************** */ + +/* ------------------ Mode function --------------------- */ +/* mode(n) returns a list of all the modal elements in the list n */ +mode(n):= block([i,j,count_elements,counts,highest_count,mode_set], + count_elements: makelist(0,i,1,length(n)), + for i: 1 thru length(n) do + (for j: 1 thru length(n) do + (if n[i]=n[j] then count_elements[i]: count_elements[i]+1)), + counts: listify(setify(count_elements)), + highest_count:counts[length(counts)], + mode_set:{}, + for i:1 thru length(n) do + (if count_elements[i]=highest_count then mode_set: union(mode_set,{n[i]})), + mode_list:listify(mode_set), + return(mode_list) +)$ + +/* ********************************** */ +/* cassession2 I/O management */ +/* ********************************** */ + +/* Current statement identifier */ +%stmt: "0"$ + +/* Collected errors */ +%ERR: ["stack_map"]$ + +/* Collected notes */ +%NOTES: ["stack_map"]$ + +/* Collected feedback */ +%FEEDBACK: ["stack_map"]$ + +/* Function to declare errors from within logic. */ +/* With reference to position in logic. */ +_APPEND_ERR(err_list, reference) := if ev(stackmap_has_key(%ERR, %stmt), simp) + then + %ERR:stackmap_set(%ERR, %stmt, append(stackmap_get(%ERR,%stmt),[[err_list,reference]])) + else + %ERR:stackmap_set(%ERR, %stmt, [[err_list,reference]])$ + +_UNDO_ERR(err_list, reference) := block([%_tmp], + if (ev(stackmap_has_key(%ERR, %stmt), simp)) then ( + %_tmp: stackmap_get(%ERR,%stmt), + %_tmp: delete([err_list,reference], %_tmp), + %ERR: stackmap_set(%ERR, %stmt, %_tmp) + ) +)$ + +/* Function to attach a note to the current statement. */ +_APPEND_NOTE(note) := if ev(stackmap_has_key(%NOTES, %stmt), simp) + then + %NOTES:stackmap_set(%NOTES,%stmt,append(stackmap_get(%NOTES,%stmt),[note])) + else + %NOTES:stackmap_set(%NOTES,%stmt,[note])$ + +_RESET_NOTES() := %NOTES:stackmap_unset(%NOTES,%stmt)$ + +/* Function to attach a note to the current statement. */ +_APPEND_FEEDBACK(feedback) := if ev(stackmap_has_key(%FEEDBACK, %stmt), simp) + then + %FEEDBACK:stackmap_set(%FEEDBACK,%stmt,append(stackmap_get(%FEEDBACK,%stmt),[feedback])) + else + %FEEDBACK:stackmap_set(%FEEDBACK,%stmt,[feedback])$ + +/* Reset any feedback. */ +_RESET_FEEDBACK() := %FEEDBACK:stackmap_unset(%FEEDBACK,%stmt)$ + +/* General error catching wrapper */ +_EC(errcatched, reference) := if errcatched = [] + then + (_APPEND_ERR([errormsgtostring()], reference), false) + else + true$ + +/* Shorthand for allowing even more to fit into the buffer. */ +/* Note that stackmap_set is not very performance optimised and + as the CS2 context newer redefines values we can just append. + If we were to use the set functionality we meet trouble at around + 250 keys. */ +/* Catch to %_tmp before placement to list to check if the value is + a list just in case there is an error of some sort, if it is not + a list then that append would do bad things. */ +_CS2v(_k,_v) := block([%_tmp], + %_tmp:[[_k, string(_v)]], + if listp(%_tmp) then _VALUES:append(_VALUES,%_tmp), + 0)$ +_CS2l(_k,_v) := block([%_tmp], + %_tmp:[[_k, stack_disp(_v, "")]], + if listp(%_tmp) then _LATEX:append(_LATEX,%_tmp), + 0)$ +_CS2dv(_k,_v) := block([%_tmp, simp], + /* We don't want to simplify products with zero to zero here. */ + simp:false, + %_tmp:[[_k, stack_dispvalue(_v)]], + if listp(%_tmp) then _DVALUES:append(_DVALUES,%_tmp), + 0)$ +_CS2dvv(_k,_v) := (_CS2v(_k,_v),_CS2dv(_k,_v),0)$ + +_CS2out() := ( + _RESPONSE : stackmap_set(_RESPONSE, "timeout", false), + _RESPONSE : stackmap_set(_RESPONSE, "values", _VALUES), + if length(%ERR) > 1 then + _RESPONSE : stackmap_set(_RESPONSE, "errors", %ERR), + if length(%NOTES) > 1 then + _RESPONSE : stackmap_set(_RESPONSE, "notes", %NOTES), + if length(%FEEDBACK) > 1 then + _RESPONSE : stackmap_set(_RESPONSE, "feedback", %FEEDBACK), + print("STACK-OUTPUT-BEGINS>"), + print(stackjson_stringify(_RESPONSE)), + print(" 17 and ?subseq(ex,1,17) = "\\begin{verbatim}" then + ex: ?subseq(ex, 18, ev(?length(ex)-18, simp)), + ex +)$ + +/* Display of numbers. Thanks to Robert Dodier. */ +stackintfmt: "~d"; +stackfltfmt: "~a"; +stackfltsep: "."; +texput_decimal(ex):= stackfltsep:ex$ + +?texnumformat(x) := block([tx], + if ev(floatnump(x), simp) then block( + tx:ev(printf(false, stackfltfmt, x), simp) + ) else if ev(integerp(x),simp) then ( + if (is(stackintfmt="~r") or is(stackintfmt="~:r")) then + tx:sconcat("\\text{",ev(printf(false, stackintfmt, x), simp),"}") + else + tx:ev(printf(false, stackintfmt, x), simp) + ) else + tx:string(x), + /* We need this separation because validation displays trailing zeros and this is controlled by stackfltfmt. */ + if is(stackfltsep = ",") then ( + tx:ssubst("\\ ", ",", tx), + tx:ssubst("{,}", ".", tx) + ), + tx +)$ +/* Some systems are throwing an error here, which is spurious. */ +errcatch(compile(?texnumformat)); + +/* **************************************************** */ +/* Display: Subscripts, and strip singular + operators. */ +/* **************************************************** */ + +stack_disp_sub_script(ex) := block([s], + if taylorp(ex) then return(ex), + if safe_setp(ex) then return(apply(set, maplist(stack_disp_sub_script, args(ex)))), + if arrayp(ex) then return(arraymake(op(ex), maplist(stack_disp_sub_script, args(ex)))), + /* The following are not, strictly speaking, a subscript issue, but we don't want another recursive call. */ + /* Strip out empty plus operators, which cause problems in display with simp:false. */ + if is(safe_op(ex)="+") and is(length(args(ex))=1) then return(stack_disp_sub_script(first(args(ex)))), + /* Now deal with supscripts. */ + if not(atom(ex)) then return(apply(op(ex), maplist(stack_disp_sub_script, args(ex)))), + if simp_numberp(ex) or stringp(ex) or ex or not(ex) then return(ex), + /* Check for an explicit entry in the texput database for this atom. */ + if stringp(get_texword(ex)) then return(ex), + s: string(ex), + s: split(s, "_"), + /* If we can't parse the string back, just use the string. */ + s: maplist(lambda([ex], block([parsed], parsed:errcatch(parse_string(ex)), if emptyp(parsed) then ex else first(parsed))), s), + stack_disp_sub_script_helper(s) +)$ + +stack_disp_sub_script_helper(l) := block( + if length(l) = 1 then return(first(l)), + texsub(stack_disp_sub_script_helper(reverse(rest(reverse(l)))), first(reverse(l))) +)$ + +/* This function turns a list into a string representation of its arguments, without braces. + stackcommaseparate([a,b,pi]); + "a, b, pi" + Not the TeX version, "a, b, \pi". + + Useful for passing values to Javascript, R and so on, or generating data for students. +*/ +stack_disp_comma_separate(ex):= block( + if not(listp(ex)) then error("stack_disp_comma_separate: expects its argument to be a list"), + return(simplode(maplist(string, ex), ", ")) +)$ + +/* ********************************** */ +/* Display: colour */ +/* ********************************** */ + +COLOR_LIST:["red", "Blue", "YellowOrange", "Bittersweet", "BlueViolet", "Aquamarine", "BrickRed", + "Apricot", "Brown", "BurntOrange", "CadetBlue", "CarnationPink", "Cerulean", "CornflowerBlue", + "CyanDandelion", "DarkOrchid", "Emerald", "ForestGreen", "Fuchsia", "Goldenrod", "Gray", + "Green", "JungleGreen", "Lavender", "LimeGreen", "Magenta", "Mahogany", "Maroon", "Melon", + "MidnightBlue", "Mulberry", "NavyBlue", "OliveGreen", "Orange", "OrangeRed", "Orchid", + "Peach", "Periwinkle", "PineGreen", "Plum", "ProcessBlue", "Purple", "RawSienna", "Red", + "RedOrange", "RedViolet", "Rhodamine", "RoyalBlue", "RoyalPurple", "RubineRed", "Salmon", + "SeaGreen", "Sepia", "SkyBlue", "SpringGreen", "Tan", "TealBlue", "Thistle", "Turquoise", + "Violet", "VioletRed","WildStrawberry", "Yellow", "YellowGreen", "BlueGreen"]$ +COLOR_LIST_LENGTH:length(COLOR_LIST)$ + +/* Decolour function */ +detexcolor(ex) := block([argsex], + if mapatom(ex) then return(ex), + argsex:args(ex), + if op(ex) = texcolor then return(detexcolor(argsex[2])), + if op(ex) = texcolorplain then return(detexcolor(argsex[2])), + if op(ex) = "/" then return(detexcolor(argsex[1])/detexcolor(argsex[2])), + map(detexcolor, ex) +)$ + +/* We only display matrices with the following matching pairs of delimiters. + Mismatching pairs ruins the API, so we can't have lmxchar and rmxchar as arbitrary. + The list has three arguments, the first is the search string, the second is the left + parentheses, and the third is the right parentheses. +*/ +stack_matrix_pairs:[ ["[", "[", "]"], ["(", "(", ")"], ["\{", "\\{", "\\}"], ["{", "\\{", "\\}"], ["", "", ""], [".", "", ""], ["|", "|", "|"]] $ + +stack_matrix_disp(m):= block([ret, lp, rp, parens], + if not(matrixp(m)) then error("stack_matrix_disp: argument must be a matrix."), + if not(stringp(lmxchar)) then error("stack_matrix_disp requires lmxchar to be a string. "), + parens: sublist(stack_matrix_pairs, lambda([ex], is(first(ex)=lmxchar))), + if emptyp(parens) then error(concat("stack_matrix_disp: cannot display matrices with parentheses ", string(lmxchar))), + parens: first(parens), + lp: second(parens), + rp: third(parens), + ret: maplist(lambda([ex], maplist(tex1, args(ex))), args(m)), + ret: maplist(lambda([ex], simplode(ex, " & ")), ret), + ret: simplode(ret, " \\\\ "), + ret: sconcat("\\begin{array}{", simplode(maplist(lambda([ex], "c"), first(args(m)))), "} ", ret, " \\end{array}"), + if ""#lp then + ret: sconcat("\\left", lp, ret), + if ""#rp then + ret: sconcat(ret, "\\right", rp), + ret +)$ + +texput(matrix, stack_matrix_disp)$ + +/* ********************************** */ +/* Display: Sort out the unary minus */ +/* ********************************** */ + +/* To see an interesting example, see the following. + simp:false; + p:y^3-2*y^2-8*y; + ?print(p); + + In the structure of this expression the first negative coefficient is -(2y^2) BUT the second is -(8)*y. + + ((MPLUS) ((MEXPT) $Y 3) ((MMINUS) ((MTIMES) 2 ((MEXPT) $Y 2))) ((MTIMES) ((MMINUS) 8) $Y)) + + This again is a crucial but subtle difference.... + + The following functions sort this out, pulling "-" out the front in a specific situation: that of + a product with a negative number at the front. + + Another interesting example. This illustrates the interaction with quotients. + simp:false; + p:x^7/7-2*x^6/3-4*x^3/3; +*/ + +/* Traverses an entire expression and ensures that "-"(number) really is the negative number. */ +/* Although we ultimately need to transform all integers back into "-"(number) for correct display */ +/* this function gives us a definite form for comparison purposes in the interim.*/ +unary_minus_traverse(ex) := block( + /* We want atom here, not mapatom to catch a[4]. */ + if atom(ex) then return(ex), + if op(ex) = "-" and numberp(first(args(ex))) then return(ev(ex,simp)), + if arrayp(ex) then return(arraymake(op(ex), maplist(unary_minus_traverse, args(ex)))), + apply(op(ex), map(unary_minus_traverse, args(ex)) ) +)$ + + +/* Pulls out "-" to the front of any expression in a sum of products which needs it. */ +/* For example, -(2*y^2) is ok */ +/* But (-3)*7 is not. */ +unary_minus_pull(ex) := block([ex2], + if atom(ex) then return(ex), + ex2: apply(op(ex), map(unary_minus_pull, args(ex))), + if arrayp(ex) then ex2:arraymake(op(ex), map(unary_minus_pull, args(ex))), + if op(ex) = "+" then ex2:apply("+", map(unary_minus_pull_helper, args(ex2))), + if op(ex) = "*" then ex2:unary_minus_pull_helper(ex2), + return(ex2) +)$ + +/* Looks for */ +/* - a negative number */ +/* - a product of an number and something. */ +/* - a quotient of an number and something. */ +/* Makes sure any minus sign is the top element */ +unary_minus_pull_helper(ex) := block([fe], + if numberp(ex) and is(ex<0) then return(-(ev(-1*ex,simp))), /* Turns -8 into "-"(8) */ + if atom(ex) then return(ex), + fe: first(args(ex)), /* First element of the arguments. Is this a negative number? */ + if op(ex) = "*" then + if numberp(fe) and is(fe<0) + then return(-(apply("*", append([ev(-fe,simp)], rest(args(ex)))))), + /* (-4*x^3)/4 is transformed into -(4*x^3)/4 */ + if op(ex) = "/" and safe_op(fe) = "-" then + return(-(apply("/",append(args(fe),[second(args(ex))])))), + return(ex) +)$ + + +/* Sorts out display of expressions in the case simp:false */ +unary_minus_sort(ex) := block([ex2], + if simp or atom(ex) or taylorp(ex) or functionp(ex) then return(ex), + ex2: unary_minus_traverse(ex), + return(unary_minus_pull(ex2)) +)$ + +/* ********************************** */ +/* Generate feedback */ +/* ********************************** */ + +StackAddFeedback(fb, key, [ex]) := block([str, exprs, jloop], + /* Note, the ex's are assumed to already be strings. + There would be no other way to sort out the $ vs $$'s */ + /* Loop over the expressions */ + exprs: "", + ev(for jloop:1 thru length(ex) do + /* HACK: !quot! needs to be replaced with " when we get into PHP. */ + exprs: concat(exprs, " , !quot!", ex[jloop], "!quot! "), simp), + str: sconcat("stack_trans('", key, "'", exprs, "); !NEWLINE!"), + _APPEND_FEEDBACK(str), + return(sconcat(fb, str)) +)$ + +/* Separate notes with puncutation, to enable clearer reading + and the possibility to split them. */ +StackAddNote(exnote, newnote) := (_APPEND_NOTE(newnote),concat(exnote, newnote, ". "))$ + +StackTrimNote(ex) := strim(". ", ex)$ + +/* In many situations we just need the most basic object. */ +StackBasicReturn(validity, result, note) := [validity, result, StackAddNote("", note), StackAddFeedback("", note)]$ + +/* note the extra closing ] here. The corresponding opening [ is generated in PHP. */ +/* This is about the most ugly API ever, but there we go..... */ + +/* *************************************/ +/* Output graphics, */ +/* *************************************/ + +set_plot_option([run_viewer, false]); +set_plot_option([plot_format, gnuplot]); +set_plot_option([nticks, 50]); +set_plot_option([adapt_depth, 10]); +set_plot_option([gnuplot_default_term_command, ""]); + +plot(ex, [ra]) := /*stack_web_plot*/ + block([simp:true, tfn, tfnp1, tfnp2, tfnp3, afn, ufn, lvs, preamble, sysp, sysr, + filename, tn, alt, altc, alttext, ral, ralforbid, pltargs, plotfunmake, plotdebug, + plotgrid2d, size, psize, plot_size, plot_tags, stack_mtell_quiet, plotpid, margin], + stack_mtell_quiet:true, + plotdebug: false, + /* Check for grid2d in the plotoptions. */ + plotgrid2d: false, + if member(grid2d, ra) or member(STACKGRID, ra) then + plotgrid2d: true, + /* Arguments to plot must be lists. */ + ral: sublist(ra, listp), /* The actual arguments used by plot. */ + /* Check expressions to be plotted has/have only one variable. */ + ex: ev(ex, nouns, simp), + /* Remove logarithms to other bases from expressions. */ + if not(freeof(lg, ex)) then + ex:ev(ex, lg=logbasesimp), + lvs: listofvars(%_ce_rem(ex)), + lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric or ex = minus or ex = plus))), + if length(lvs)>1 then + error("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)"), + /*********************/ + /* Sort out alt-text */ + kill(alt), + alttext: concat("STACK auto-generated plot of ", string(ex), " with parameters ", string(ral)), + altc: sublist(ral, lambda([ex], if listp(ex) then is(first(ex) = alt) else false)), + if not(emptyp(altc)) then (ral:delete(first(altc), ral), alttext:second(first(altc))), + if not(stringp(alttext)) then error("Plot error: the alt tag definition must be a string, but it is not."), + /*******************/ + /* Check for size. */ + kill(size, psize), + plot_size: PLOT_SIZE, + psize: sublist(ral, lambda([ex], if listp(ex) then is(first(ex) = size) else false)), + if not(emptyp(psize)) then (ral:delete(first(psize), ral), plot_size:[second(first(psize)), third(first(psize))]), + if not(listp(plot_size)) then error("Plot error: plot_size must be a list of two positive integers."), + if not(all_listp(lambda([ex], is((integerp(ex) and is(ex>0))=true)), plot_size)) then + error("Plot error: plot_size must be a list of two positive integers, but got:", string(plot_size)), + psize:concat(" size ", string(plot_size[1]), ", ", string(plot_size[2])), + /*******************/ + /* Check for tags. */ + kill(ptags,plot_tags), + plot_tags: PLOT_TAGS, + ptags:sublist(ral, lambda([ex], if listp(ex) then is(first(ex) = plottags) else false)), + if not(emptyp(ptags)) then (ral: delete(first(ptags), ral), plot_tags: second(first(ptags))), + if not(is(plot_tags=true or plot_tags=false)) then error("Plot error: the plottags option must be a Boolean."), + /**********************************************************/ + /* Remove from option list ral any non-permitted options. */ + kill(y), + permitted_options: [y, xlabel, ylabel, label, legend, color, style, point_type, nticks, logx, logy, axes, box, plot_realpart, yx_ratio, xtics, ytics, ztics, adapt_depth, margin], + /* In the case the list of variables is empty we need to add in "x" so the constant functions can be plotted. */ + if not(emptyp(lvs)) then permitted_options:append([first(lvs)], permitted_options) + else permitted_options:append([x], permitted_options), + ralforbid:sublist(ral, lambda([ex], not(member(first(ex), permitted_options)))), + if not(emptyp(ralforbid)) then + error("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)"), + /********************************************/ + /* Create a unique identifier for the plot. */ + plotpid:errcatch(?getpid()), + if (emptyp(plotpid) or not(integerp(first(plotpid)))) then plotpid:"pid-missing" else plotpid:string(first(plotpid)), + tn: string(absolute_real_time()), + STACK_PLOT_UNIQUE_NUMBER:STACK_PLOT_UNIQUE_NUMBER + 1, + filename:concat("stackplot", "-", plotpid, "-", string(STACK_PLOT_UNIQUE_NUMBER), "-", tn,"-",string(rand(10^8))), + /* Sort out the name of the image file and its url. */ + afn: concat("'", IMAGE_DIR, filename, ".", PLOT_TERMINAL, "'"), + if PLOT_TERMINAL="svg" then + afn: concat(IMAGE_DIR, filename, ".", PLOT_TERMINAL), + ufn: concat("", str_to_html(alttext), ""), + if plot_tags then + ufn: concat("
", ufn, "
"), + /* Sort out plot_options and preamble*/ + preamble: "", + if not(member(xlabel, maplist(first, ral))) then ral: append(ral, [[xlabel, ""]]), + if not(member(ylabel, maplist(first, ral))) then ral: append(ral, [[ylabel, ""]]), + if member(legend, maplist(first, ral)) then block([lv], + /* If we have [legend, true] then we should use the default legend */ + lv: sublist(ral, lambda([ex], (first(ex)=legend))), + if second(first(lv))=true then ral:delete([legend, true], ral) + ) else block( + ral: append(ral, [[legend, false]]) + ), + if not(PLOT_TERMINAL="svg") then preamble:concat(preamble, "set terminal ", PLOT_TERMINAL, " ", PLOT_TERM_OPT, psize, " +set output ", afn), + /* Gnuplot only allows alpha-numeric characters in the plot name, so not even spaces! This is a problem with the string function. */ + if PLOT_TERMINAL="svg" then preamble:concat("set terminal ", PLOT_TERMINAL, psize, " ", PLOT_TERM_OPT), + /* Reduce margins around plots: this can be added in again with CSS if required, but can't be clipped later. */ + if member(margin, maplist(first, ral)) then block([lv], + /* If we have [legend, true] then we should use the default legend */ + lv: first(sublist(ral, lambda([ex], listp(ex) and (first(ex)=margin)))), + ral:delete(lv, ral), + if not(numberp(second(lv))) then error("Plot error: margin must be a number, found: ", second(lv)), + lv:second(lv), + if PLOT_TERMINAL="svg" then preamble:concat(preamble, ascii(10), "set lmargin ", string(lv), ascii(10), "set rmargin ", string(lv), ascii(10), "set tmargin ", string(lv), ascii(10), "set bmargin ", string(lv)) + ), + /* Add in the command for the grid. */ + if plotgrid2d and MAXIMA_VERSION_NUM>34 then + ral: append(ral, [grid2d]), + if plotdebug then print(preamble), + if PLOT_TERMINAL="svg" then set_plot_option([svg_file, afn]), + if PLOT_TERMINAL="svg" then + set_plot_option([gnuplot_svg_term_command, preamble]) + else + set_plot_option([gnuplot_preamble, preamble]), + /* Sort out the name and location of temporary Gnuplot files. */ + tfn:concat(filename, ".plt"), + /* Temporary file is referred to three times. */ + /* 1. when Maxima writes it. */ + /* 2. when Gnuplot receives its location as an argument. */ + /* 3. when we delete it. */ + /* On linux these are the same: the full path. */ + tfnp1: concat(maxima_tempdir, filename, ".plt"), + tfnp2: tfnp1, + tfnp3: tfnp1, + /* On Windows, for more recent versions of Maxima, add slashes to the filename for Gnuplot. */ + if MAXIMA_PLATFORM="win" and MAXIMA_VERSION_NUM>35 then block( + tfnp1: concat(filename, ".plt"), + tfnp2: ssubst("\\\\", "\\", tfnp2) + ), + set_plot_option([gnuplot_out_file, tfnp1]), + if plotdebug then print(plot_options), + /* Create and execute the actual plot commands. */ + ex:%_ce_expedite(ex), + pltargs: append([ex], ral), + if plotdebug then print(pltargs), + plotfunmake: funmake(plot2d, pltargs), + ev(plotfunmake), + sysp: concat(GNUPLOT_CMD, " ", tfnp2), + sysr: concat(DEL_CMD, " ", tfnp3), + if plotdebug then print([sysp,sysr]), + system(sysp), + if not(plotdebug) then system(sysr), + simp: old_simp, + return(ufn) +)$ + + +/* ********************************** */ +/* Algebraic tests */ +/* ********************************** */ + +/* A general, all purpose answer test based maximum simplification. + This function is a wrapper for AtAlgEquivfun(SA,SB) +*/ +ATAlgEquiv(SA,SB) := block([simp:true, ret, newret, SAN, SBN], + /* Turn on simplification and error catch */ + if is(_EC(errcatch(SA:ev(stack_noteq_single_solve(SA), simp, nouns, rat)), "") = false) then + return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]), + /* We need a copy here because lists are passed by reference and the colouring of incorrect entries + causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */ + SAN:copy(SA), + if is(_EC(errcatch(SB:ev(stack_noteq_single_solve(SB), simp, nouns, rat)), "") = false) then + return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]), + /* Start recursive process */ + SBN:copy(SB), + /* Start recursive process */ + ret:ATAlgEquivfun(SAN, SBN), + /* Can we find a permutation of the variables? */ + if ret[2]=0 then block([p1], + /* Start with a clean copy of SA to remove any texcolor. */ + SAN:copy(SA), + p1:subst_equiv(SAN, SB, []), + /* Actually, at this point 2008/7/7, we don't want to give this feedback. Just leave an answer note. */ + /* if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), StackAddFeedback(ret[4], "Subst", stack_disp(p1, "d"))] */ + if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), ret[4]] + ), + return(ret) +)$ + +/* An algebraic equivalence test which does not evaluate noun forms, but does other simplifications. +*/ +ATAlgEquivNouns(SA,SB) := block([simp:true, ret, newret, SAN, SBN], + /* Turn on simplification and error catch */ + if is(_EC(errcatch(SA:ev(SA, simp, rat)), "") = false) then + return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_SAns"), ""]), + /* We need a copy here because lists are passed by reference and the coloring of incorrect entries + causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */ + SAN:copy(SA), + if is(_EC(errcatch(SB:ev(SB, simp, rat)), "") = false) then + return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_TAns"),""]), + SBN:copy(SB), + /* Start recursive process */ + ret:ATAlgEquivfun(SAN, SBN), + /* Can we find a permutation of the variables? */ + if ret[2]=0 then block([p1], + /* Start with a clean copy of SA to remove any texcolor. */ + SAN:copy(SA), + p1:subst_equiv(SAN, SBN), + /* Actually, at this point 2008/7/7, we don't want to give this feedback. Just leave an answer note. */ + /* if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), StackAddFeedback(ret[4], "Subst", stack_disp(p1, "d"))] */ + if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), ret[4]] + ), + return(ret) +)$ + +/* ATAlgEquivfun is a recursive "thing" comparing function. It is designed to + cope with a variety of different objects, e.g. lists of inequalities etc. + + Returns [valid, RawMark, AnswerNote, FeedBack] + where valid = true/false + RawMark = true or false + AnswerNote = "string", + FeedBack = StackFeedback +*/ +ATAlgEquivfun(SA, SB) := block([SApoly, SBpoly, keepfloat, RawMark, FeedBack, AnswerNote, ret], + Validity:true, RawMark:false, FeedBack:"", AnswerNote:"", + keepfloat:true, + /* Reduce the number of different operators, where possible. */ + if ev(is(count_op(SA,STACKpmOPT)=1), simp) then SA:pm_replace(SA), + if ev(is(count_op(SB,STACKpmOPT)=1), simp) then SB:pm_replace(SB), + /* Are we dealing with strings? */ + if stringp(SB) then + if stringp(SA)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_string")) + else + return([true, is(SA=SB), "ATAlgEquiv_String", ""]), + /* Are we dealing with matrices? */ + if matrixp(SB) then + if matrixp(SA)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_matrix")) + else + return(ATMatrix(SA, SB)), + /* Are we dealing with lists? */ + if listp(SB) then + if listp(SA)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_list")) + else + return(ATList(SA, SB)), + /* Are we dealing with sets? */ + if safe_setp(SB) then + if safe_setp(SA)=false then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_set")) + else + return(ATSet(SA, SB)), + /* Are we dealing with non-trivial sets? */ + if realset_soft_p(SB) and not(trivialintervalp(SB)) then + if not(realset_soft_p(SA)) then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_realset")), + /* No specific function here, as "all" and "none" can show up with equations. */ + /* Are we dealing with a function? */ + if functionp(SB) then + if functionp(SA)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_function")) + else + return(ATFunction(SA, SB)), + /* Are we dealing with a hidden equation? */ + SApoly:SA, + if logicp(SA) and freeof(STACKpmOPT, SA) then SApoly:logic_to_poly(SA), + SBpoly:SB, + if logicp(SB) and freeof(STACKpmOPT, SA) then SBpoly:logic_to_poly(SB), + /* Don't use logic_edgep(SB) here, as this includes "true" and "false". A teacher should use all/none if they mean equations. */ + if (equationp(SBpoly) or SB = all or SB = none) then + /* But the student can also use true/false here. Note the conscious asymmetry. */ + if (equationp(SApoly) or logic_edgep(SA)) then + return(ATEquation(SApoly, SBpoly)) + else if equationp(SB) and not (equationp(SA) or logicp(SA) or inequalityp(SA)) then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_equation")), + /* Did the student type in a simple equation, but the teacher did not? */ + if (equationp(SA) and not(op_usedp(SA, abs)) and not(op_usedp(SA, STACKpmOPT))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")), + /* Are we dealing with an inequality? */ + if inequalityp(SB) or equationp(SB) then + if inequalityp(SA)#true and equationp(SA)#true and logicp(SA)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_inequality")) + else + return(ATInequality(SA, SB)), + if logicp(SB) then + if logicp(SA)#true and inequalityp(SA)#true and op_usedp(SA,abs)#true then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_logic")) + else + return(ATLogic(SA, SB)), + if realset_soft_p(SA) and realset_soft_p(SB) then + return(ATRealSet(SA, SB)), + /* Has the student typed in the wrong type?*/ + if expressionp(SA)=false then + return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_expression")), + /* Otherwise we have two expressions*/ + if SA=SB then + RawMark:true + else if algebraic_equivalence(SA, SB) then + RawMark:true + else block([SAd, SBd, exeq], + /* algebraic_equivalence is not free, so only execute this when we need to do so. */ + SAd:exdowncase(SA), + SBd:exdowncase(SB), + /* If lower case variables are defined then this can throw an error here. E.g. SA:1/B, but b:0 elsewhere.... */ + exeq:errcatch(algebraic_equivalence(SAd, SBd)), + if is(exeq = []) then print("STACK: ignore previous error. (WrongCase)") else + if (SAd#SA or SBd#SB) and first(exeq) then + AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase") + ), + ret:[Validity, RawMark, AnswerNote, FeedBack], + return(ret) + )$ + +stack_noteq_single_solve(ex) := block( + if atom(ex) then return(ex), + if freeof("#", ex) then return(ex), + if not(safe_op(ex)="#") then return(apply(op(ex), map(stack_noteq_single_solve, args(ex)))), + /* Only attempt solving in single variables cases. */ + if length(listofvars(ex))=1 then return(apply("nounand", map(lambda([ex2], subst("#","=",ex2)), solve(first(ex)=second(ex))))), + ex +)$ + +stack_noteq_single_remove(ex) := block( + if atom(ex) then return(ex), + if freeof("#", ex) then return(ex), + if not(safe_op(ex)="#") then return(apply(op(ex), map(stack_noteq_single_remove, args(ex)))), + /* Only attempt solving in single variables cases. */ + if length(listofvars(ex))=1 then return((first(ex)second(ex))), + ex +)$ + +/* An answer test based on two lists for SA and SB */ +ATList(SA,SB) := block([AddFeedBack, SAN, SAl, SBl, ret, retnew, kloop, AnsNotes], + /* Get sizes of lists */ + SAN:SA, + SAl:length(SA), + SBl:length(SB), + if (SAl#SBl) then + return([true, false, StackAddNote("","ATList_wronglen"), StackAddFeedback("", "ATList_wronglen", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]), + + /* Apply ATAlgEquivfun to each element pair */ + ret:[true, true, "", ""], + AddFeedBack:false, + AnsNotes:[], + for kloop:1 thru SAl do block([retnew, SAk, SBk], + SAk:ev(SA[kloop]), + SBk:ev(SB[kloop]), + retnew:ATAlgEquivfun(SAk, SBk), + ret[1]:ret[1] and retnew[1], + ret[2]:ret[2] and retnew[2], + if not(retnew[3] = "") then + AnsNotes:cons(concat(string(kloop), ": ", StackTrimNote(retnew[3])), AnsNotes) + else if retnew[2] = false then + AnsNotes:cons(string(kloop), AnsNotes), + if retnew[2] = false then block( + /* ret[4]:concat(ret[4], retnew[4]), */ + if not(listp(SAk) or matrixp(SAk) or safe_setp(SAk)) then block( + SAN[kloop]:texcolor("red", SAk) + ), + AddFeedBack:true + ) + ), + if AddFeedBack = true then block( + ret[3]:StackAddNote("", concat("(ATList_wrongentries ", simplode(reverse(AnsNotes), ", "), ")") ), + ret[4]:concat(StackAddFeedback("", "ATList_wrongentries", stack_disp(SAN, "d")), ret[4]) + ), + return(ret) +)$ + +/* An answer test based on two sets of real numbers. */ +ATRealSet(SA, SB) := block( + /* Tidy up intervals as much as possible. Some tidying might be possible even with realset_soft_p rather than realsets.*/ + SA:interval_tidy(SA), + SB:interval_tidy(SB), + + if is(SA=SB) then + return([true, true, StackAddNote("", "ATRealSet_true"), ""]), + return([true, false, StackAddNote("", "ATRealSet_false"), ""]) +)$ + +/* Equations */ +/* Note, this uses expand, which will break large expressions. */ +stack_eqnprepare(ex) := block([ret, keepfloat], + keepfloat:true, + ret:fullratsimp(trigexpand(rhs(ex)-lhs(ex))), + ret:ret*denom(ret), + return(expand(ret)) +)$ + +stack_eqncompare(SA, SB, sl) := block([ret,G0,G1], + G0 :poly_buchberger(SA, sl), + G1 :poly_buchberger(SB ,sl), + ret:poly_grobner_equal(G0, G1, sl), + return(ret) +)$ + +stack_assignmentp(ex) := block( + if atom(ex) then return(false) + else if op(ex)#"=" then return(false) + else if atom(lhs(ex)) and not(real_numberp(lhs(ex))) and real_numberp(rhs(ex)) then return(true) + else return(false) +)$ + +stack_assignmentrev(ex) := block( + if atom(ex) then return(ex) + else if op(ex)#"=" then return(ex) + else if real_numberp(lhs(ex)) and not(real_numberp(rhs(ex))) then return(rhs(ex)=lhs(ex)) + else return(ex) +)$ + +/* Take a list of equations, and re-evaluate it in the context of any assignments of the form d=10 + This is needed in practice with systems of equations, as students may write [d=10, d=v*t] */ +stack_eval_assignments(ex) := block([asl, sl], + if not(listp(ex)) then return(ex), + sl:maplist(stack_assignmentrev, ex), + asl:sublist(sl, stack_assignmentp), + if not(emptyp(asl)) then block( + sl:listify(setdifference(setify(sl), setify(asl))), + sl:ev(sl, asl) + ), + return(sl) +)$ + +/* Two equations are the "same" when they have identical roots + with identical multiplicities. */ +ATEquation(SA, SB) := block([keepfloat, RawMark, SA1, SB1, SB2, Rationalex1, Rationalex2, Rationalex, edgecase], + keepfloat:false, + RawMark:false, + + /* This test assumes we have equations or edge cases. + Type checking here saves a lot of calls to algebraic_equivalence. */ + if not((equationp(SA) or logic_edgep(SA)) and (equationp(SB) or logic_edgep(SB))) then + return([true, false, "ATEquation_not_both_equations", ""]), + + /* Check for an equation satisfied by anything. */ + if algebraic_equivalence(lhs(SA), rhs(SA)) then SA:all, + if algebraic_equivalence(lhs(SB), rhs(SB)) then SB:all, + + /* If we have one side is zero, then make sure it is the rhs. */ + if algebraic_equivalence(lhs(SA),0) then SA:rhs(SA)=0, + if algebraic_equivalence(lhs(SB),0) then SB:rhs(SB)=0, + + /* Trap edge cases. */ + /* If we have empty equations we should bail now. */ + if ATEquation_emptyp(lhs(SB)-rhs(SB)) then + if ATEquation_emptyp(lhs(SA)-rhs(SA)) then + return([true, true, "ATEquation_empty", ""]) + else return([true, false, "ATEquation_empty_fail", ""]), + + edgecase:false, + if logic_edgep(SA) or logic_edgep(SB) then edgecase:true, + + /* That said in lots of situations students will be asked to enter an equation. */ + /* First we try the obvious of checking equivalence of each side. */ + /* This catches lots of otherwise problematic cases. */ + if not(edgecase) and algebraic_equivalence(lhs(SA), lhs(SB)) then + if algebraic_equivalence(rhs(SA), rhs(SB)) then + return([true, true, "ATEquation_sides", ""]) + else return([true, false, "ATEquation_lhs_notrhs", ""]), + if not(edgecase) and algebraic_equivalence(lhs(SA), rhs(SB)) then + if algebraic_equivalence(rhs(SA), lhs(SB)) then + return([true, true, "ATEquation_sides_op", ""]) + else return([true, false, "ATEquation_lhs_notrhs_op", ""]), + /* First try without expanding out the equations */ + Rationalex1:ev(lhs(factor(SA))-rhs(factor(SA)), simp), + Rationalex2:ev(lhs(factor(SB))-rhs(factor(SB)), simp), + + if ATEquation_zerop(Rationalex2) then + if ATEquation_zerop(Rationalex1) then + return([true, true, "ATEquation_zero", ""]) + else return([true, false, "ATEquation_zero_fail", ""]), + if numberp(float(abs(Rationalex1/Rationalex2))) then + return([true, true, "", ""]), Rationalex1:num(ratsimp(Rationalex1)), + Rationalex2:num(ratsimp(Rationalex2)), + if algebraic_equivalence(abs(Rationalex1/Rationalex2), 1) then + return([true, true, "ATEquation_ratio", ""]), + Rationalex:ratsimp(Rationalex1/Rationalex2), + if numberp(float(abs(Rationalex))) then + return([true, true, "ATEquation_num", ""]), + Rationalex:ratsimp(rectform((%i*Rationalex1)/Rationalex2)), + if numberp(float(abs(Rationalex))) then + return([true, true, "ATEquation_num_i", ""]), + /* Guard clause for efficiency. */ + if freeof(abs, SA) and freeof(abs, SB) then + return([true, false, "ATEquation_default", ""]), + + /* Now try to get rid of absolute value signs. */ + Rationalex1:abs_replace_eq(SA), + Rationalex1:lhs(Rationalex1)-rhs(Rationalex1), + Rationalex2:abs_replace_eq(SB), + Rationalex2:lhs(Rationalex2)-rhs(Rationalex2), + if ATEquation_zerop(Rationalex2) then + if ATEquation_zerop(Rationalex1) then + return([true, true, "ATEquation_abs_zero", ""]) + else return([true, false, "ATEquation_abs_zero_fail", ""]), + if numberp(float(abs(Rationalex1/Rationalex2))) then + return([true, true, "", ""]), + Rationalex1:num(ratsimp(Rationalex1)), + Rationalex2:num(ratsimp(Rationalex2)), + if algebraic_equivalence(abs(Rationalex1/Rationalex2), 1) then + return([true, true, "ATEquation_abs_ratio", ""]), + Rationalex:ratsimp(Rationalex1/Rationalex2), + if numberp(float(abs(Rationalex))) then + return([true, true, "ATEquation_abs_num", ""]), + R:ratsimp(rectform((%i*Rationalex1)/Rationalex2)), + if numberp(float(abs(Rationalex))) then + return([true, true, "ATEquation_abs_num_i", ""]), + + return([true, false, "ATEquation_default", ""]) + )$ + +/* A predicate to decide if we have an empty equation, satisfied by anything. */ +ATEquation_zerop(ex) := block( + if is(ex=all) or is(ex=true) then return(true), + if is(ex=none) or is(ex=false) then return(false), + if algebraic_equivalence(ex, 0) then return(true), + return(false) +)$ + +/* A predicate to decide if we have no solutions (without solving). */ +ATEquation_emptyp(ex) := block( + if is(ex=all) or is(ex=true) then return(false), + if is(ex=none) or is(ex=false) then return(true), + if algebraic_equivalence(ex, 0) then return(false), + if emptyp(listofvars(ex)) then return(true), + return(false) +)$ + +ATInequality(SA, SB) := block([RawMark, FeedBack, AnswerNote, SA1, SB1, samex], + RawMark:false, FeedBack:"", AnswerNote:"", + if debug then print("ATInequality(", SA, ", ", SB, ")"), + /* Write the inequalities in canonical form then compare. */ + SA:logical_normal(SA), + SB:logical_normal(SB), + if debug then print("ATInequality(", SA, ", ", SB, ")"), + if SA = SB then RawMark:true + else if stack_single_variable_solver(SA)=stack_single_variable_solver(SB) then block( + RawMark:true, + AnswerNote:StackAddNote("", "ATInequality_solver") + ), + /* Now try to give some basic feedback: potential for more work to recurse over complex expressions... */ + if safe_op(SA) = ">" and safe_op(SB) =">=" then block( + RawMark:false, + AnswerNote:StackAddNote("", "ATInequality_strict"), + FeedBack:StackAddFeedback("", "ATInequality_strict") + ), + if safe_op(SA) = ">=" and safe_op(SB) =">" then block( + AnswerNote:StackAddNote("", "ATInequality_nonstrict"), + FeedBack:StackAddFeedback("", "ATInequality_nonstrict") + ), + if (">" = safe_op(SA) or ">=" = safe_op(SA)) and (">" = safe_op(SB) or ">=" = safe_op(SB)) then block( + SA1:ev(part(SA, 1), simp), + SB1:ev(part(SB, 1), simp), + if algebraic_equivalence(-1*SA1,SB1) then block( + AnswerNote:StackAddNote(AnswerNote, "ATInequality_backwards"), + FeedBack:StackAddFeedback(FeedBack, "ATInequality_backwards") + ) + ), + return([true, RawMark, AnswerNote, FeedBack]) +)$ + + +/* This (experimental) code decides if two functions are the same. Strict notion currently. */ +ATFunction(SA, SB) := block([RawMark, FeedBack, AnswerNote, df, SA1, SB1, SAd1, SBd1], + RawMark:true, FeedBack:"", AnswerNote:"", + if not(functionp(SA)) then return([false, 0, "ATFunction_SA_not_function", FeedBack]), + if not(functionp(SB)) then return([false, 0, "ATFunction_TA_not_function", FeedBack]), + /* These may contain errors like 1/0 that need to be caught. + Actually also the function signature could have similar issues. + But as those have been ignored in the tests lets not catch those. */ + SA1:args(SA), + SB1:args(SB), + if not _EC(errcatch( + (SAd1:second(SA1), + SBd1:second(SB1))), + "") then return([false, -1, "", FeedBack]), + /* Are the functions the same name? */ + if not(is(op(first(SA1)) = op(first(SB1)))) then block( + AnswerNote:StackAddNote("", "ATFunction_wrongname"), + RawMark:false + ), + /* Are the arguments the same? */ + if is(length(args(first(SA1))) = length(args(first(SB1)))) then block( + if not(is(args(first(SA1)) = args(first(SB1)))) then block( + AnswerNote:StackAddNote(AnswerNote, "ATFunction_arguments_different"), + SAd1:subst(zip_with("=", args(first(SA1)), args(first(SB1))), SAd1) + ) + ) else block( + AnswerNote:StackAddNote(AnswerNote, "ATFunction_length_args"), + RawMark:false + ), + df:ATAlgEquivfun(SAd1, SBd1), + if second(df) then block( + AnswerNote:StackAddNote(AnswerNote, "ATFunction_true") + ) else block ( + AnswerNote:StackAddNote(AnswerNote, "ATFunction_false"), + RawMark:false + ), + return([true, RawMark, AnswerNote, FeedBack]) +)$ + +/* An answer test based on two matrices for SA and SB. */ +ATMatrix(SA, SB) := block([RawMark, FeedBack, AnswerNote, str, ret, SAr, SAc, SBr, SBc, k, AddFeedBack], + RawMark:true, FeedBack:"", AnswerNote:"", + /* Get sizes of matrices */ + SAr:length(SA), + SAc:length(SA[1]), + SBr:length(SB), + SBc:length(SB[1]), + if (SAr#SBr) then + return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i"))]), + if (SAc#SBc) then + return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i"))]), + /* Check they are equal */ + ret:[true, true, "", ""], + AddFeedBack:false, + for kloop:1 thru SAr do block([retnew], + retnew:ATAlgEquivfun(SA[kloop], SB[kloop]), + ret[1]:ret[1] and retnew[1], + ret[2]:ret[2] and retnew[2], + ret[3]:concat(ret[3], " ", retnew[3]), + if retnew[2] = false then AddFeedBack:true + ), + if AddFeedBack = true then block( + /* TO-DO: better answernotes for matrices */ + ret[3]:StackAddNote("", "ATMatrix_wrongentries"), + ret[4]:StackAddFeedback("", "ATMatrix_wrongentries", stack_disp(SA, "d")) + ), + return(ret) + )$ + +/* An answer test based on two sets for SA and SB. */ +ATSet(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAl, SBl, ZM], + RawMark:true, FeedBack:"", AnswerNote:"", + /* Get sizes of sets. */ + SAl:ev(cardinality(SA), simp), + SBl:ev(cardinality(SB), simp), + if (SAl#SBl) then + return([true, false, StackAddNote("", "ATSet_wrongsz"), StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]), + /* Check they are equal */ + + SA:ATSets_prepare(SA), + SB:ATSets_prepare(SB), + + if (subsetp(SA, SB) and subsetp(SB, SA)) then + return([true, true, AnswerNote, FeedBack]), + /* Can we give feedback on which are wrong ? */ + ZM:setdifference(SA, SB), + if not(emptyp(ZM)) then + FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(ZM, "d")), + return([true, false, StackAddNote("","ATSet_wrongentries"), FeedBack]) +)$ + +/* Note, this test (ATSets not ATSet as above) gives much more detailed feedback + than the Algebraic equivalence test. +*/ +ATSets(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp], + RawMark:true, FeedBack:"", AnswerNote:"", + /* Turn on simplification and error catch */ + if (is(_EC(errcatch(SAsimp:ev(SA, simp, nouns)), "") = false)) then + return([false, false, StackAddNote("", "ATSets_STACKERROR_SAns"), ""]), + if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then + return([false, false, StackAddNote("", "ATSets_STACKERROR_TAns"), ""]), + if not(safe_setp(SB)) then + return(StackBasicReturn(false, false, "ATSets_SB_not_set")), + if not(safe_setp(SA)) then + return(StackBasicReturn(false, false, "ATSets_SA_not_set")), + + SAsimp:ATSets_prepare(SAsimp), + SBsimp:ATSets_prepare(SBsimp), + + /* Look for duplicate entries. */ + if is(length(SAsimp)= maxscore) then block (maxscore:score, index:i) + ), + return([decimalplaces(maxscore, 5), index]) +)$ + +ATLevenshtein(SA, SB, SO) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, SBsimpmod, SOsimp, tol, + levupper, levwhitespace, allowf, denyf], + RawMark:true, FeedBack:"", AnswerNote:"", + /* Turn on simplification and error catch. */ + if (is(_EC(errcatch(SAsimp:ev(SA, simp, nouns)), "") = false)) then + return([false,false,StackAddNote("","ATString_STACKERROR_SAns"),""]), + if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then + return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]), + if (is(_EC(errcatch(SOsimp:ev(SO, simp, nouns)), "") = false)) then + return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]), + + if not(stringp(SAsimp)) then + return(StackBasicReturn(false, false, "ATLevenshtein_SA_not_string")), + /* The teacher's answer must be the [allow,deny] lists of strings. */ + if not(listp(SBsimp)) then + return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")), + if not(is(length(SBsimp)=2)) or not(listp(first(SBsimp))) or not(listp(second(SBsimp))) or not(all_listp(stringp, flatten(SBsimp))) then + return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")), + if emptyp(first(SBsimp)) then + return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")), + + /* Sort out options. */ + tol:SOsimp, + levupper:true, + levwhitespace:true, + if listp(SOsimp) then block( + tol:first(SOsimp), + SOsimp:setify(rest(SOsimp)), + if elementp(CASE, SOsimp) then levupper:false, + if elementp(WHITESPACE, SOsimp) then levwhitespace:false + ), + + if not(numberp(tol)) then + return(StackBasicReturn(false, false, "ATLevenshtein_tol_not_number")), + if not(booleanp(levupper)) then + return(StackBasicReturn(false, false, "ATLevenshtein_upper_not_boolean")), + + SBsimpmod:SBsimp, + /* Pre-process strings to upper case. */ + if (levupper=true) then block( + SAsimp:supcase(SAsimp), + SBsimpmod:maplist(lambda([ex2], maplist(supcase, ex2)), SBsimpmod) + ), + /* Tidy whitespace. */ + if (levwhitespace=true) then block( + SAsimp:ssquish(SAsimp), + SBsimpmod:maplist(lambda([ex2], maplist(ssquish, ex2)), SBsimpmod) + ), + + /* Find the closest allow string. */ + allowf:levenshtein_compare_strings(SAsimp, first(SBsimpmod)), + allowf:[first(allowf), SBsimp[1][second(allowf)]], + /* Find the closest deny string. */ + denyf:[0, []], + if not(emptyp(second(SBsimp))) then block( + denyf:levenshtein_compare_strings(SAsimp, second(SBsimpmod)), + denyf:[first(denyf), SBsimp[2][second(denyf)]] + ), + + if debug then print(allowf), + if debug then print(denyf), + + AnswerNote:sconcat(": ", string([allowf, denyf])), + /* Are we closer to a deny string? */ + if first(allowf)=0.9999 then + return([true, true, StackAddNote("ATLevenshtein_true", AnswerNote), ""]), + + return([true, true, StackAddNote("ATLevenshtein_match", AnswerNote), StackAddFeedback("", "ATLevenshtein_match", stack_disp(second(allowf), "i"))]) +)$ + +/* **************************************** */ +/* Helper functions for string manipulation */ +/* **************************************** */ + +/* Remove all the characters from the string rem from the string st. + Useful for removing all punctuation characters. */ +sremove_chars(rem, st) := sremove_chars_helper(charlist(rem), st)$ +sremove_chars_helper(remlist, st) := if emptyp(remlist) then st else sremove_chars_helper(rest(remlist), sremove(first(remlist), st))$ + +/* + (1) Replace all tab and newline characters with spaces. + (2) Trim spaces from each end. + (3) Remove all multiple spaces and replace with a single space. + + (This is called str_squish in the R language, and squish in other languages.). +*/ +ssquish(st) := block( + st:ssubst(" ", tab, st), + st:ssubst(" ", newline, st), + st:strim(" ", st), + /* while is(slength(st)>slength(st:ssubst(" ", " ", st))) do true,*/ + st:regex_subst(" ", "\\s+", st), + st +)$ + +/* **************************************** */ +/* A wrapper for an all purpose answer test + which checks things are of the same "type". + Based upon the results of AtAlgEquivfun(SA,SB) +*/ +/* **************************************** */ +ATSameType(SA, SB) := block([ret], + ret:ATSameTypefun(SA,SB), + /* This test gives no feedback */ + ret[3]:"", + ret[4]:"", + return([true, ret[2], ret[3], ret[4]]) +)$ + +ATSameTypefun(SA, SB) := block([simp:true, ret], + /* Turn on simplification and error catch */ + SA:errcatch(ev(SA, simp, nouns)), + if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATSameTypefun_STACKERROR_SAns"), ""]), + SA:SA[1], + SB:errcatch(ev(SB, simp, nouns)), + if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATSameTypefun_STACKERROR_TAns"), ""]), + SB:SB[1], + /* Start recursive process. */ + ret:ATAlgEquivfun(SA, SB), + /* Send back result. */ + if ret[1] then + return([true, true, ret[3], ret[4]]) + else + return([true, false, ret[3], ret[4]]) +)$ + +/* Tests if the SA equals SB in lowest terms, and gives feedback. + Also checks that the denominator is clear of things like sqty(2) and complex numbers. + Note, this is identical to ATAlgEquiv with simp:false otherwise. */ +ATLowestTerms(SA, SB) := block([simp:false, ret, validity, mark, FeedBack, AnswerNote, SAA, rd], + /* Turn on simplification and error catch */ + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA = [STACKERROR]) or is(SAA = [])) then + return([false, false, StackAddNote("", "ATLowestTerms_STACKERROR_SAns"), ""]), + SB:errcatch(ev(SB, simp, nouns)), + if (is(SB = [STACKERROR]) or is(SB = [])) then + return([false, false, StackAddNote("", "ATLowestTerms_STACKERROR_TAns"), ""]), + SB:SB[1], + /* Unpack and check other property */ + validity:true, + mark:true, + AnswerNote:"", + FeedBack:"", + if all_lowest_termsex(SA) = false then block([badNos,a], + mark:false, + badNos:list_expression_numbers(SA), + badNos:sublist(badNos,lambda([ex], if lowesttermsp(ex) then false else true)), + AnswerNote:StackAddNote(AnswerNote, "ATLowestTerms_entries"), + if badNos=[] then + FeedBack:StackAddFeedback("", "ATLowestTerms_wrong", "") + else + FeedBack:StackAddFeedback("", "ATLowestTerms_entries", stack_disp(badNos, "d")) + ), + /* Check for problems in the denominator. */ + rd:rationalized(SA), + if not(is(rd=true)) then block( + mark:false, + fbn:"ATLowestTerms_not_rat", + FeedBack: StackAddFeedback(FeedBack, fbn, stack_disp(rd, "d")), + AnswerNote:StackAddNote(AnswerNote, fbn) + ), + return([validity, mark, AnswerNote, FeedBack]) +)$ + +ATSubstEquiv([ex]) := block([simp:true, SA, SB, SC, ret, SAc, SBc], + /* Turn on simplification and error catch */ + SA:errcatch(ev(first(ex), simp, nouns)), + if is(SA=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_SAns"), ""]), + SA:SA[1], + SB:errcatch(ev(second(ex), simp, nouns)), + if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_TAns"), ""]), + SB:SB[1], + SC:[[]], + if length(ex)>2 then + SC:errcatch(ev(third(ex), simp, nouns)), + if is(SC=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_Opt"), ""]), + SC:SC[1], + if not(listp(SC)) then return([false, false, StackAddNote("", "ATSubstEquiv_Opt_List"), StackAddFeedback("", "ATSubstEquiv_Opt_List")]), + /* Copy SA and SB. If they are lists or matrices then ATAlgEquivfun potentially colours wrong entries. */ + SAc:copy(SA), + SBc:copy(SB), + ret:ATAlgEquivfun(SAc, SBc), + /* Can we find a permutation of the variables? */ + if ret[2]=false then block([p1], + p1:subst_equiv(SA, SB, SC), + if p1#[] and p1#false then ret:[true, true, StackAddNote("", concat("ATSubstEquiv_Subst ", string(p1))), StackAddFeedback("", "Subst", stack_disp(p1, "d"))] + ), + /* Send back result */ + return(ret) +)$ + +/* Deal with exprssions which have logical operations. */ +ATLogic(SA, SB) := block([SAL, SBL, res], + res:[true, false, "", ""], + /* Write the statements in canonical form then compare. */ + if ev(is(count_op(SA,STACKpmOPT)=1), simp) then SA:pm_replace(SA), + if ev(is(count_op(SB,STACKpmOPT)=1), simp) then SB:pm_replace(SB), + SA:ev(logical_normal(SA), simp), + SB:ev(logical_normal(SB), simp), + /* Check for the empty set. */ + if equationp(SA) and numberp(lhs(SA)) and not(algebraic_equivalence(lhs(SA), 0)) then SA:none, + if equationp(SB) and numberp(lhs(SB)) and not(algebraic_equivalence(lhs(SB), 0)) then SB:none, + if (debug) then print("ATLogic: [", string(SA), " | ", string(SB), "]"), + if SA = SB then + return([true, true, StackAddNote("", "ATLogic_True"), ""]), + SAP:ev(stack_single_variable_solver(SA), simp), + SBP:ev(stack_single_variable_solver(SB), simp), + if (debug) then print("ATLogic_to_poly_solver: [", string(SAP), " | ", string(SBP), "]"), + if SAP=SBP then + return([true, true, StackAddNote("", "ATLogic_Solver_True"), ""]), + SAP:ev(logic_to_poly(SA), simp), + SBP:ev(logic_to_poly(SB), simp), + if (debug) then print("ATLogic_to_poly: [", string(SAP), " | ", string(SBP), "]"), + if equationp(SAP) and equationp(SBP) then block( + res:ATEquation(SAP, SBP), + if (debug) then print(res) + ), + return(res) +)$ + +ATPropLogic(SA,SB) := block([simp:true, ret, SAc, SBc], + /* Turn on simplification and error catch */ + SA:errcatch(ev(SA, simp, nouns)), + if is(SA=[STACKERROR]) then return([false, false, StackAddNote("", "ATPropLogic_STACKERROR_SAns"), ""]), + SA:SA[1], + SB:errcatch(ev(SB, simp, nouns)), + if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATPropLogic_STACKERROR_TAns"), ""]), + SB:SB[1], + /* We don't want noun forms getting in the way here. */ + SA:noun_logic_remove(SA), + SB:noun_logic_remove(SB), + /* Can we find a permutation of the variables? */ + if logic_equiv(SA, SB) then + return([true, true, "", ""] + ), + /* Send back result */ + return([true, false, "", ""]) +)$ + +/**********************************************/ +/* */ +/* System Equivalence Test */ +/* */ +/* An addition to STACK using Grobner Bases */ +/* */ +/* Matthew Badger, 2011 */ +/* */ +/**********************************************/ + +/* + + What these functions do: + + - Determine whether the student's and teacher's answers are systems of equations + - Convert the two systems of equations into two systems of expressions + - Determine whether both systems are systems of multivariate polynomials + - Compare the variables in student's and teacher's answers, if they're not the same tell the student + - Find their Buchberger polynomials of the two systems + - Use the Buchberger polynomials to compare the Grobner bases of the two systems + - If the Grobner bases are not equal, determine whether the student's is a subset of the teacher's + - If student's system has equations which should not be there, tell them which ones. +*/ + +/* + Main function of the System Equivalence test + + Takes two inputs, checks whether they are + lists of polynomials and delegates everything + else to other functions. + + Process: + + - Is each answer a list? + - Is each list element not an atom? + - Is each list element an equation? + - Is each list element a polynomial? +*/ + +/* Edited files: SysEquiv.php, AnsTestcontroller.php, lang/en/stack.php */ + +ATSysEquiv(SA,SB):=block([keepfloat,Validity, RawMark, FeedBack, AnswerNote, SAA, SAB, S1, S2, varlist, GA, GB, ret], + Validity:true, RawMark:false, FeedBack:"", AnswerNote:"", + keepfloat:true, + + /* Turn on simplification and error catch */ + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATSysEquiv_STACKERROR_SAns"), ""]), + SAB:errcatch(ev(SB, simp, nouns)), + if (is(SAB=[STACKERROR]) or is(SAB=[])) + then return([false, false, StackAddNote("", "ATSysEquiv_STACKERROR_TAns"), ""]), + + /* Are both answers lists? */ + if not listp(SA) then + return(StackBasicReturn(false, false, "ATSysEquiv_SA_not_list")), + if not listp(SB) then + return(StackBasicReturn(false, false, "ATSysEquiv_SB_not_list")), + + /* Are all list elements not atoms? */ + if ev(all_listp(atom, SA), simp) then + return(StackBasicReturn(false,false,"ATSysEquiv_SA_not_eq_list")), + if ev(all_listp(atom, SB), simp) then + return(StackBasicReturn(false,false,"ATSysEquiv_SB_not_eq_list")), + + /* Are all list elements equations? */ + if ev(not all_listp(equationp, SA), simp) then + return(StackBasicReturn(false, false, "ATSysEquiv_SA_not_eq_list")), + if ev(not all_listp(equationp, SB), simp) then + return(StackBasicReturn(false, false, "ATSysEquiv_SB_not_eq_list")), + + /* Turn our equations into expressions, and remove assignments. */ + S1: ev(maplist(stack_eqnprepare, stack_eval_assignments(SA)), simp), + S2: ev(maplist(stack_eqnprepare, stack_eval_assignments(SB)), simp), + /* Is S1 is empty? This means we only had assignments in the answer, + i.e. the answer was in a "solved" form, e.g. x=1. */ + if emptyp(S1) and ev(equal(setify(maplist(stack_eqnprepare, SA)), setify(maplist(stack_eqnprepare, flatten(solve(S2,listofvars(S2)))))),simp) then + return([true,true,StackAddNote("","ATSysEquiv_SA_Completely_solved"),""]), + if emptyp(S1) then + return([true,false,StackAddNote("","ATSysEquiv_SA_Not_completely_solved"),""]), + + /* Turn our equations into expressions, and keep assignments. */ + S1: ev(maplist(stack_eqnprepare, SA), simp), + S2: ev(maplist(stack_eqnprepare, SB), simp), + + /* Is each expression a polynomial? */ + if not all_listp(polynomialpsimp, S1) then + return(StackBasicReturn(false,false,"ATSysEquiv_SA_not_poly_eq_list")), + if not all_listp(polynomialpsimp, S2) then + return(StackBasicReturn(false,false,"ATSysEquiv_SB_not_poly_eq_list")), + + /* + At this point have two lists of polynomials. We now check whether the + student's and teacher's polynomials have the same variables. If they do, + we find their Grobner bases and determine whether the systems of + equations have the same solutions + */ + + varlist: listofvars(S2), + if ev(not(is(setify(listofvars(S1))=setify(varlist))), simp) then + return(ATSysEquivVars(S1,S2)), + + GA :ev(poly_buchberger(S1,varlist),simp), + GB :ev(poly_buchberger(S2,varlist),simp), + kill(S1,S2), + + + /* Determine whether our two lists of polynomials have the same Grobner Bases */ + if poly_grobner_equal(GA, GB, varlist) then + return([true,true,"",""]), + + /* + We now know the student's answer is in the correct form but there is + something wrong with it. From here we use the grobner package to + determine which, if any, of their equations is correct. + */ + + return(ATSysEquivGrob(GA, GB, SA, varlist)) +)$ + + +/* Takes two lists of expressions and compares the variables in each */ + +ATSysEquivVars(S1,S2):=block([XA,XB], + XA: setify(listofvars(S1)), + XB: setify(listofvars(S2)), + if subsetp(XA,XB) then + return(StackBasicReturn(true,false,"ATSysEquiv_SA_missing_variables")), + if subsetp(XB,XA) then + return(StackBasicReturn(true,false,"ATSysEquiv_SA_extra_variables")), + return(StackBasicReturn(true,false,"ATSysEquiv_SA_wrong_variables")) +)$ + +/* + Grobner basis comparison. + + This function takes two Grobner bases and a set of variables and determines + whether the student's system is underdetermined or overdetermined. It also + takes the student's original system so that if it is overdetermined it can + tell them which equations should not be there. +*/ + +ATSysEquivGrob(GA, GB, SA, varlist) := block([retl, ret, kloop], + + /* Is the student's system underdetermined? */ + + if poly_grobner_subsetp(GA,GB,varlist) then + return(StackBasicReturn(true,false,"ATSysEquiv_SA_system_underdetermined")), + + /* + Given that the student's system is neither underdetermined nor equal to + the teacher's, we need to find which equations do not belong in the system. + */ + + ret:[], + + for kloop:1 thru length(SA) do block([], + if ev(poly_grobner_member(stack_eqnprepare(stack_eval_assignments(SA[kloop])), GB, varlist), simp) then + ret:append(ret,[SA[ev(kloop, simp)]]) + else + ret:append(ret,[texcolor("red", SA[ev(kloop, simp)])])), + + return([true,false,StackAddNote("","ATSysEquiv_SA_system_overdetermined"),StackAddFeedback("","ATSysEquiv_SA_system_overdetermined", stack_disp(ret, "d"))]) +)$ + +/*****************************************************************/ + +/* An answer test based on the Maxima's notion of equals. */ +ATCasEqual(SA,SB) := + block([keepfloat:true, Validity:true, RawMark:false, FeedBack:"", AnswerNote:"", SAA, SBB, SAN, SBN], + SAN:copy(SA), + SBN:copy(SB), + + /* Strip out previous simplificiation. */ + SAN:parse_string(string(SAN)), + SBN:parse_string(string(SBN)), + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then return([false,false,StackAddNote("","ATCASEqual_STACKERROR_SAns"),""]), + SBB:errcatch(ev(SB, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then return([false,false,StackAddNote("","ATCASEqual_STACKERROR_TAns"),""]), + + /* Now actually apply this test */ + if equals_commute_associate(SAN,SBN) then + (RawMark:true, AnswerNote:"") + else + (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")), + + if SAN=SBN then + return([Validity, true, StackAddNote("","ATCASEqual_true"), FeedBack]), + + /* We need to check things are of the same type */ + ret:ATSameTypefun(SAN,SBN), + if ret[2]=false then + return([true, false, StackAddNote("ATCASEqual ", StackTrimNote(ret[3])), ret[4]]), + ret:block([simp:true, ret], ATAlgEquivfun(SAN, SBN)), + if ret[2]=true then + return([true, false, StackAddNote("ATCASEqual (AlgEquiv-true)", StackTrimNote(ret[3])), ""]), + + AnswerNote:"ATCASEqual_false", + return([Validity, RawMark, StackAddNote("",AnswerNote),FeedBack]) + )$ + +/* SA>SB? */ +ATGT(SA,SB) := + block([keepfloat, Validity, RawMark, FeedBack, AnswerNote, str, ex], + Validity:true, RawMark:false, FeedBack:"", AnswerNote:"Not number", + keepfloat:true, /* See pg 23 */ + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATGT_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SB, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATGT_STACKERROR_TAns"), ""]), + + ex:ev(float(trigreduce(trigexpand(SA-SB))),simp), + if numberp(ex) then + if ex>0 then + (RawMark:true, AnswerNote:StackAddNote("","ATGT_true")) + else + ( AnswerNote:StackAddNote("","ATGT_false")), + return([Validity,RawMark,AnswerNote,FeedBack]) + )$ + +/* SA>=SB? */ +ATGTE(SA,SB) := + block([keepfloat, Validity, RawMark, FeedBack, AnswerNote, str, ex, SAA, SBB], + Validity:true, RawMark:false, FeedBack:"", AnswerNote:"Not number", + keepfloat:true, + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATGTE_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SB, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATGTE_STACKERROR_TAns"), ""]), + + ex:ev(float(trigreduce(trigexpand(SA-SB))),simp), + if numberp(ex) then + if ex>=0 then + (RawMark:true, AnswerNote:StackAddNote("","ATGTE_true") ) + else + ( AnswerNote:StackAddNote("","ATGTE_false")), + return([Validity,RawMark,AnswerNote,FeedBack]) + )$ + + +/* irred_Q(p,v) is true iff */ +/* (1) p is degree 0 in v */ +/* (2.1) p is linear in v, and the coefficients have no common factors */ +/* (2.2) p is linear in v, and the coefficients of v is -1 */ +/* (3) p is quadratic, the coefficients have no common factors */ +/* and p does not factor over the **rational numbers** */ + +/* Is p an irreducible polynomial term in v, over the rationals Q? */ +/* Returns a list, of [true/false, FeedBack, true/false] */ +/* The third argument is the special case when we just have an integer factor to pull out. Needed for PartFrac. */ + +irred_Q(p, v) := block([ret,deg,cl,ci], + if ev(not(polynomialp(p, [v], lambda([ex], freeof(v, ex)))), simp) then return([false, StackAddFeedback("", "ATFacForm_notpoly")]), + deg:ev(hipow(expand(p), v), simp), + /* Now perform the general test. */ + cl:ev(map(second, coeff_list_nz(expand(p), v)), simp), + /* Are all coefficients of p are integers? (note, negative number don't count as integers here!) */ + ci:all_listp(lambda([ex], integerp(ev(abs(ex), simp))), cl), + /* General starting position. */ + ret:[factorp(p), "", false], + /* Special cases. */ + if is(deg=0) then ret:[true,"",false], + /* Special situation for the linear case to avoid strange results. */ + if is(deg=1) then block([lt], + lt:ev(bothcoef(p, v), simp), + if lt[1]=1 or lt[2]=1 then ret:[true, "", false] + ), + /* Special case of quadratics, which are irreducible over the rationals. */ + if is(deg=2) then block([a, b, c, q], + q:ev(expand(p), simp), + a:ev(coeff(q, v, 2), simp), + b:ev(coeff(q, v, 1), simp), + c:ev(coeff(q, v, 0), simp), + if (b=0 and c=0 and a>1 and ratnump(ev(sqrt(a), simp))) then ret:[true, StackAddFeedback("", "irred_Q_optional_fac", stack_disp(p,"i")), false] + else if (b=0 and c=0) then ret:[true, "", false] + else if ratnump(ev(sqrt(b^2-4*a*c), simp)) then ret:[false, "", false] + ), + /* Check we have a common integer factor: note can't use GCD function which only allows 2 arguments. */ + if length(cl)>1 and ci and commonfaclist(cl)>1 then ret:[false, StackAddFeedback("", "irred_Q_commonint"), true], + if deg>2 then block([q], + /* Take out any integer common factor. */ + q:p, + if length(cl)>1 and ci then q:ev(expand(p/commonfaclist(cl)), simp), + if is(ev(q#factor(q), simp)) then ret:[false, ret[2], false] + ), + return(ret) +)$ + +/* Picks apart an expression and gives some feedback */ +/* on why this is not a factored expression. */ +FacForm_UnPick(SA, SO) := block([negdistrib, partswitch, fb, kloop, irred, res, end], + negdistrib:false, + partswitch:true, + fb:"", + res:true, + if safe_op(SA) = "-" then SA:part(SA,1), + if atom(SA) then return([true, ""]), + if op(SA) = "+" then return(irred_Q(SA, SO)) else + if op(SA) = "^" then return(irred_Q(part(SA, 1), SO)), + /* So we have a *, or a / */ + for kloop:1 step 1 while ev(part(SA, kloop), simp)#end do block( + /* We just need to go one level down! */ + irred:block([SB], + SB:part(SA, ev(kloop, simp)), + if safe_op(SB) = "-" then SB:part(SB, 1), + if atom(SB) then return([true, ""]), + if safe_op(SB) = "+" then return(irred_Q(SB, SO)), + if safe_op(SB) = "^" then return(irred_Q(part(SB, 1), SO)) else return([false, ""]) + ), + res:res and irred[1], + if irred[1] = false then block( + fb:StackAddFeedback(fb, "FacForm_UnPick_morework", stack_disp(part(SA, ev(kloop, simp)), "i")), + fb:concat(fb, irred[2]) + ) + ), + return([res,fb]) +)$ + + +/* Factored form of a polynomial? */ +ATFacForm(SA, SB, SO) := block([negdistrib, RawMark, FeedBack, AnswerNote, ret, str, SAA, SBB, SOO, coefl, facdum], + negdistrib:false, + Validity:true, RawMark:true, FeedBack:"", AnswerNote:"", + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATFacForm_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SB, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATFacForm_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(SO, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATFacForm_STACKERROR_Opt"), ""]), + + /* SA should be only an expression. */ + if expressionp(SA)=false then + return([false,false,StackAddNote("", "ATFacForm_SA_not_expression"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]), + + /* If we don't have an atom as the teacher's variable, then we need to make a substitution. */ + if atom(SO)#true then (SA:subst(facdum, SO, SA), SB:subst(facdum, SO, SB), SO:facdum), + ret: FacFormfun(SA, SB, SO), + return(ret) + )$ + +FacFormfun(SA, SB, SO) := block([val, rawmk, ansnote, fb, ret, deg, aequiv, up, cont], + val:true, rawmk:true, fb: "", ansnote: "", + ret:[val, rawmk, ansnote, fb], + aequiv:algebraic_equivalence(SA, SB), + SA:flatten(SA), + /* An integer answer is always correct. */ + if (integerp(SA)) then + if (SA=SB) then + ansnote:StackAddNote(ansnote, "ATFacForm_int_true") + else block( + rawmk: false, + ansnote:StackAddNote(ansnote, "ATFacForm_int_false") + ) + else block( + /* Check for the correct answer. */ + if (aequiv and factorp(SA)) then + ansnote:StackAddNote("", "ATFacForm_true") + else block( + if (factorp(SA)) then block( + /* We need to provide some feedback, if possible. */ + ansnote:StackAddNote(ansnote, "ATFacForm_isfactored"), + fb:StackAddFeedback(fb, "ATFacForm_isfactored") + ) + else block( + up:FacForm_UnPick(SA, SO), + if (up[1]=false) then block( + rawmk:false, + ansnote:StackAddNote(ansnote, "ATFacForm_notfactored"), + fb:StackAddFeedback(fb, "ATFacForm_notfactored"), + fb:concat(fb, up[2]) + ) else block( + ansnote:StackAddNote(ansnote, "ATFacForm_default_true") + ) + ), + /* Check for algebraic equivalence */ + if (true#aequiv) then ( + rawmk:false, + ansnote:StackAddNote(ansnote, "ATFacForm_notalgequiv"), + fb:StackAddFeedback(fb, "ATFacForm_notalgequiv") + ) + ) + ), + ret:[val, rawmk, ansnote, fb], + return(ret) +)$ + +/* An answer test based expandp(sa). */ +/* Note, the SB is a dummy to allow one mechanism for calling functions. */ +ATExpanded(SA,SB) := + block([keepfloat, Validity, RawMark, FeedBack, AnswerNote, SA1], + Validity:true, RawMark:false, FeedBack:"", AnswerNote:"", SA1:[], + keepfloat:true, + + /* SA should be only an expression. */ + SA1:errcatch(ev(SA, simp, nouns)), + if is(SA1=[STACKERROR]) then return([false, false, StackAddNote("", "ATExpanded_STACKERROR_SAns"), ""]), + /* */ + if expressionp(SA)=false then + return([false, false, StackAddNote("", "ATExpanded_SA_not_expression"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]), + if expandp(SA) then + return([true, true, StackAddNote("", "ATExpanded_TRUE"), ""]) + else + return([true, false, StackAddNote("", "ATExpanded_FALSE"), ""]) + )$ + + +/* *************************ATPartFrac Test**************************** */ +/* requires: Student Answer, */ +/* [Teachers Question, */ +/* Respect To which the fractions are parted, */ +/* Formative Feedback] */ +/* returns: [validity,rawmk,ansnote,fb] */ +/* CASE 1: topOp is divisor - single fraction */ +/* CASE 2: CORRECT answer - true */ +/* CASE 3: Different Variables - diff vars */ +/* CASE 4: Different amount of parts - Diff parts */ +/* CASE 5: Different Numerator - ret factored expression */ +/* CASE 6: Different Denominator - ret sDenom and tDenom */ +/* ******************************************************************** */ + +ATPartFrac(SA, SB, SO) := block([negdistrib, Validity, rawmk, fb, ansnote, ret, facdum, wrt, SAA, SBB, SOO], + negdistrib:false, + facdum:'facdum, + Validity:true, rawmk:true, fb:"", ansnote:"", + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATPartFrac_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SBL, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATPartFrac_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(SO, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATPartFrac_STACKERROR_Opt"), ""]), + + /* SA should be only an expression. */ + if expressionp(SA)=false then + return([false, false, StackAddNote("", "ATPartFrac_SA_not_expression"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]), + + /* SB should be only an expression. */ + if expressionp(SB)=false then + return([false, false, StackAddNote("", "ATPartFrac_TA_not_expression"), StackAddFeedback("", "ATPartFrac_error_list")]), + + /* If we don't have an atom as the teacher's variable, then we need to make a substitution */ + if atom(SO)#true then (SA:subst(facdum, SO, SA), SB:subst(facdum, SO, SB), SO:facdum), + ret: PartFracfun(SA, SB, SO), + return(ret) + )$ + +/* An expression is in partial fraction form when */ +/* it is a sum of rational terms. In each term */ +/* - the denominator of each term is a power of an */ +/* irreducible (not factorable) polynomial and */ +/* - the numerator is a polynomial of smaller degree */ +/* than that irreducible polynomial. */ +/* It is tempting to try something like the following. */ +/* tapf:ev(partfrac(ratsimp(tExpr), wrt), simp); */ +/* rawmk:second(ATEqualComAss(sExpr, tapf)); */ +/* There are at least two problems with this approach. */ +/* (i) partfrac returns terms like (1+n)^-1 not 1/(1+n), */ +/* which are problematic with simp:false. */ +/* (ii) ATEqualComAss does not accept -1/(1-n) = 1/(n-1) */ +PartFracfun(sExpr, tExpr, wrt) := block([val, rawmk, ansnote, fb, ret], + val:true, rawmk:true, fb: "", ansnote: "", + ret:[val, rawmk, ansnote, fb], + if algebraic_equivalence(sExpr, tExpr) then block([topOp, list], + topOp:op(sExpr), + list:args(sExpr), + /* Sort out any factors the student may have pulled out */ + if topOp = "*" then block( + sExpr:expand(sExpr), + topOp:op(sExpr), + list:args(sExpr) + ), + if topOp = "/" then list:[sExpr] else list:args(sExpr), + block([sargs, sdenoms], + val:true, + rawmk:true, + ansnote:StackAddNote("", "ATPartFrac_true"), + /* We need to check that each term in the student's sum is in lowest terms ... */ + if not all_listp(lambda([ex], real_numberp(gcd(num(ex), denom(ex)))), list) then block( + rawmk:false, + ansnote:StackAddNote("", "ATPartFrac_false_lowestterms") + ), + /* We need to check that each denominator is the power of an irreducible factor */ + if not all_listp(lambda([ex], PartFrac_term_p(ex, wrt)), list) then block( + rawmk:false, + ansnote:StackAddNote("", "ATPartFrac_false_factor") + ) + ), + ret:[val, rawmk, ansnote, fb], + return(ret) + ) + else if sameVars(sExpr, tExpr) then block([sDeg, tDeg, sNDeg, tNDeg], + sDeg: ev(hipow(expand(denom(factor(sExpr))), wrt), simp), + tDeg: ev(hipow(expand(denom(factor(tExpr))), wrt), simp), + sNDeg: ev(hipow(expand(num(factor(sExpr))), wrt), simp), + tNDeg: ev(hipow(expand(num(factor(tExpr))), wrt), simp), + if tDeg # sDeg then block( + val:true, + rawmk:false, + ansnote:StackAddNote("", "ATPartFrac_denom_ret"), + fb: StackAddFeedback("", "ATPartFrac_denom_ret", stack_disp(denom(factor(sExpr)), "i"), stack_disp(denom(factor(tExpr)), "i")), + ret: [val, rawmk, ansnote, fb], + return(ret) + ) else block( + val:true, + rawmk:false, + ansnote:StackAddNote("", "ATPartFrac_ret_expression"), + fb:StackAddFeedback("", "ATPartFrac_ret_expression", stack_disp(factor(sExpr), "i")), + ret:[val, rawmk, ansnote, fb] + ) + ) else block( + val:false, + rawmk:false, + ansnote:StackAddNote("", "ATPartFrac_diff_variables"), + fb:StackAddFeedback("", "ATPartFrac_diff_variables"), + ret:[val, rawmk, ansnote, fb] + ), + return(ret) +)$ + +/* Is ex a single rational expression in the correct form? */ +/* p/q^n, where q is an irreducible term in v, over the rationals Q, disregarding the special case of a numerical factor? */ +/* We also make sure we can't do long division to divide p by p^n first. */ +/* Returns true/false */ +PartFrac_term_p(ex, v) := block([n1, d1, ret], + n1:num(ex), + d1:denom(ex), + /* Can we divide through? */ + if is((degree(d1, v) < degree(n1, v)) and degree(d1, v) > 0) then return(false), + /* Ignore any power here. */ + if safe_op(d1)="^" then d1:first(args(d1)), + /* Terms of the form n1/(v-a)^m must have a numerical n1! */ + if is(degree(d1, v) = 1) and (degree(n1, v)#0) then return(false), + ret:irred_Q(d1, v), + if third(ret) then true else first(ret) +)$ + +/* ************************ATSingFracTest****************************** */ +ATSingleFrac(SA, SB) := block( + [simp:false, negdistrib, validity, rawmk, fb, fbn, ansnote, ret, SAA, SBB], + negdistrib: false, + validity:true, rawmk:false, fb:"", ansnote:"", + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATSingleFrac_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SB, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATSingleFrac_STACKERROR_TAns"), ""]), + + /* sExpr should be only an expression. */ + if expressionp(SA)=false then + return([false,false,StackAddNote("","ATSingleFrac_SA_not_expression"),StackAddFeedback("","ATAlgEquiv_SA_not_expression")]), + + if atom(SA) then + if algebraic_equivalence(SA,SB) then + return([true,true,"",""]) + else + return(StackBasicReturn(true,false,"ATSingleFrac_ret_exp")), + + /* Ignore minus signs. */ + SAA:SA, + if safe_op(SA)="-" then + SAA:first(args(SA)), + + /* Check for single fraction */ + fbn:"", + if safe_op(SAA) = "/" then block( + rawmk:true, + ansnote:"ATSingleFrac_true", + /* Look for bad devision in the numerator or denominator. */ + if ATSingleFrac_helper(num(SAA)) or ATSingleFrac_helper(denom(SAA)) then block( + rawmk:false, + ansnote:"ATSingleFrac_div") + ) + else block( + rawmk:false, + ansnote:"ATSingleFrac_part"), + fb: StackAddFeedback(fb, ansnote), + ansnote:StackAddNote("", ansnote), + /* Check for algebraic equivalence */ + if not(algebraic_equivalence(SA, SB)) then block( + rawmk:false, + fbn:"ATSingleFrac_ret_exp", + fb: StackAddFeedback(fb, fbn), + ansnote:StackAddNote(ansnote, fbn) + ), + return([validity,rawmk,ansnote,fb]) +)$ + +/* Returns true if we have fractions within sums and products. */ +ATSingleFrac_helper(ex):=block( + if atom(ex) then return(false), + if safe_op(ex)="/" then return(true), + /* We are looking for division within sums, products and differences only. */ + if safe_op(ex)="+" or safe_op(ex)="*" or safe_op(ex)="-" then + return(any_listp(ATSingleFrac_helper, args(ex))), + return(false) +)$ + +/*****************************************************************/ +/* Useful function for Partial Fractions */ +/*****************************************************************/ + +divthru(q) := + if (not atom(q) and part(q,0)="/") + then + block([num,den,divt,quo,rem], + num:part(q, 1), + den:part(q, 2), + divt:divide(num, den) , + quo:divt[1], + rem:divt[2], + quo+rem/den ) + else q; + +/*****************************************************************/ +/* Partial Fractions answer Test functions */ +/*****************************************************************/ + +/* *******Functions Used******** */ +/* isDenomSame(sExpr, tExpr) */ +/* isNumSame(sExpr, tExpr) */ +/* isPartFrac(sExpr, tExpr, wrt) */ +/* sameVars(expr1, expr2) */ +/* ***************************** */ + +/* ************Denominator Same Test*************************** */ +/* requires: Students partial Fraction part */ +/* Teachers Partial Fraction part */ +/* returns: Boolean true iff denominators are equivalent */ +/* false otherwise */ +/* ************************************************************ */ + +isDenomSame(sPFrac,tPFrac):= + ( + if denom(expand(sPFrac)) = denom(expand(tPFrac)) + then true + else + false + ); + + +/* When checking the form of a partial fraction, we need to ensure that the + *form* of the demoninators are the same. That is to say that the sets + of expressions on the denominators are equal, up to +/-1. For example, + we could have 1/(n+1)+1/(1-n) or 1/(n+1)-1/(n-1). This makes life harder! +*/ +sameDenoms(SA,TA) := block([kloop, ret, sAargs, sAset, tAargs, tAset, dTA, dTB], + tAargs:args(TA), + tAset:set(), + /* Create a set of +-1*denoms in the teacher's expression */ + for kloop:1 thru length(tAargs) do block( + dTA : ev(expand(denom(tAargs[kloop])), simp), + dTB : ev(expand(-1*denom(tAargs[kloop])), simp), + tAset : union(set(dTA, dTB), tAset) + ), + /* Create a set of +-1*denoms in the student's expression */ + sAargs:args(SA), + sAset:set(), + for kloop:1 thru length(sAargs) do block( + dTA : ev(expand(denom(sAargs[kloop])), simp), + dTB : ev(expand(-1*denom(sAargs[kloop])), simp), + sAset : union(set(dTA, dTB), sAset) + ), + ret:(subsetp(sAset, tAset) and subsetp(sAset, tAset)), + return(ret) +)$ + + +/* **************Numerator Same Test*************************** */ +/* requires: Students partial Fraction part */ +/* Teachers Partial Fraction part */ +/* returns: Boolean true iff numerators are equivalent */ +/* false otherwise */ +/* ************************************************************ */ + +isNumSame(sPFrac, tPFrac):= + ( + if num(expand(sPFrac)) = num(expand(tPFrac)) + then true + else + false + ); + + +/* ***************Variables used the Same********************** */ +/* requires: 2 Expressions */ +/* returns: true: iff expr 1 and expr2 contain same vars */ +/* false: otherwise */ +/* ************************************************************ */ + +sameVars(expr1, expr2):= + block([list1,list2], + list1: listofvars(expr1), + list2: listofvars(expr2), + if list1=list2 then true + else false + ); + +/* ********************************** */ +/* Completed squares */ +/* ********************************** */ + +ATCompSquare(SA, SB, SO) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,SAA,SBB,SOO,facdum,opa,argsa,deg,cform,ae], + Validity:true,RawMark:true, FeedBack:"", AnswerNote:"", cform:false, + SAA:errcatch(ev(SA,simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATCompSquare_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(SBL,simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATCompSquare_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(SO, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATCompSquare_STACKERROR_Opt"), ""]), + wrt:SO, + + /* SA should be only an expression. */ + if expressionp(SA)=false then + return([false, false, StackAddNote("", "ATCompSquare_STACKERROR_LIST"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]), + + /* If we don't have an atom as the teacher's variable, then we need to make a substitution */ + if atom(wrt)#true then (SA:subst(facdum, wrt, SA), SB:subst(facdum, wrt, SB), wrt:facdum), + + if member(wrt,listofvars(SB)) and not(member(wrt,listofvars(SA))) then + return([true, false, StackAddNote("", "ATCompSquare_SA_not_depend_var"), StackAddFeedback("", "ATCompSquare_SA_not_depend_var", stack_disp(wrt, "i"))]), + + opa:safe_op(SA), + + /* Special case of teacher using constant or linear quadratics */ + ae:algebraic_equivalence(SA, SB), + if ae and not(member(wrt, listofvars(SB))) then + return([true, true, StackAddNote("", "ATCompSquare_true_trivial"), ""]), + if ae and is(degree(expand(SB),wrt)=1) then + return([true, true, StackAddNote("", "ATCompSquare_true_trivial"), ""]), + + /* case: -(x-1)^2/k */ + if opa="-" then block( + SA:first(args(SA)), + /* For the algebraic equivalence test later */ + SB:-1*SB, + opa:safe_op(SA) + ), + + /* case: (x-1)^2 */ + if opa="^" and part(args(SA),2)=2 then cform:true, + + /* case: k*(x-1)^2 */ + if opa="*" then block([argsb], + argsb: sublist(args(SA), lambda([ex], elementp(wrt, setify(listofvars(ex))))), + if length(argsb)=1 then + if op(argsb[1])="^" and part(argsb[1], 2)=2 then cform:true + ), + + /* case: (x-1)^2/k */ + if opa="/" and elementp(wrt,setify(listofvars(denom(SA))))#true and atom(num(SA))#true and op(num(SA))="^" and part(num(SA),2)=2 then cform:true, + + /* The sum of somthing */ + if opa="+" then block( + argsa: sublist(args(SA),lambda([ex],elementp(wrt,setify(listofvars(ex))))), + if length(argsa)>1 then + (AnswerNote:"_no_summands",return(true)), + + if length(argsa)<1 then return(true), + + if atom(argsa[1]) then return(true), + + /* case: -(x-1)^2 + c*/ + if op(argsa[1])="-" then argsa[1]:first(args(argsa[1])), + + /* case: (x-1)^2 + c*/ + if op(argsa[1])="^" and part(argsa[1],2)=2 then cform:true, + + /* case: k*(x-1)^2 + c*/ + if op(argsa[1])="*" then block([argsb], + argsb: sublist(args(argsa[1]), lambda([ex], elementp(wrt, setify(listofvars(ex))))), + if length(argsb)=1 then + if op(argsb[1])="^" and part(argsb[1],2)=2 then cform:true + ) + ), + + /* Check for algebraic equivalence */ + if cform and ae then + return([true,true,StackAddNote("","ATCompSquare_true"),""]), + + if cform then + return([true,false,StackAddNote("","ATCompSquare_true_not_AlgEquiv"),StackAddFeedback("","ATCompSquare_not_AlgEquiv")]), + + if not(ae) then + return([true,false,StackAddNote("","ATCompSquare_false_not_AlgEquiv"),""]), + + AnswerNote:concat("ATCompSquare_false",AnswerNote), + return([true,false,StackAddNote("",AnswerNote),StackAddFeedback("",AnswerNote)]) + )$ + +/*********************/ +/* Calculus question */ +/*********************/ + +/* This function substitutes an "integrationconstant" in ex for v. + If v is a list, this substitutes as many integration constants as possible */ +subst_int_const(ex,v):=block([lv,li,ls], + lv:listofvars(ex), + li:sublist_indices(lv, lambda([ex],is(smismatch("integrationconstant",string(ex))>19) or is(smismatch("%c",string(ex))>2)) ), + if emptyp(li) then return(ex), + /* If we have only one variable v, then use this */ + if not(listp(v)) then return(subst(lv[li[1]]=v,ex)), + ls:map(lambda([n],lv[n]),li), + subst(zip_with("=",ls,v),ex) + )$ + +/* This function strips off any trailing constant of integration from an expression, which is not a number */ +strip_int_const(ex, v) := block([ex2,fargs], + ex2:ex, + if atom(ex) then return(ex), + if op(ex)="+" then + (fargs:sublist(args(ex),lambda([ex2],not(freeof(v,ex2)) or simp_numberp(ex2))), + if length(fargs)=1 then ex2:fargs[1] else ex2:apply("+",fargs)), + return(ex2))$ + +/********************************************************************/ +/* An answer test for integration questions. */ +/* sa is the students' answer, */ +/* sbl is a list consisting of (1) the answer, and (2) the variable */ +/********************************************************************/ +ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, AnswerNote, var, sbdisp, ret, cont, constint, acceptformal, atoptions], + oldsimp:simp, + simp:false, + Validity:true, RawMark:false, + FeedBack:"", AnswerNote:"", + keepfloat:true, + /* Should we be fussy about the constant of integration? */ + constint:true, + /* Should we accept formal derivatives? */ + acceptformal:false, + /* How to display the teacher's answer? */ + sbdisp:[], + + SAA:errcatch(ev(sa, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then + return([false, false, StackAddNote("", "ATInt_STACKERROR_SAns"), ""]), + SBB:errcatch(ev(sb, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then + return([false, false, StackAddNote("", "ATInt_STACKERROR_TAns"), ""]), + SOO:errcatch(ev(so, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then + return([false, false, StackAddNote("", "ATInt_STACKERROR_Opt"), ""]), + + /* We always simplify the teacher's answer. */ + sb:first(SBB), + + var:so, + /* Is the options field a variable or a list at this stage? + If so, the teacher has provided options such as + (1) the original expression for feedback purposes, + (2) asked for constants of integration to be ignored. + */ + if listp(var) then block( + atoptions:ATIntOptions(var), + if debug then print("Options: ", atoptions), + if not(equal(first(atoptions), "")) then block( + print("TEST_FAILED"), + cont:false, + RawMark:false, + FeedBack:StackAddFeedback("", "ATInt_STACKERROR_OptList"), + AnswerNote:StackAddNote("", first(atoptions)) + ), + var:second(atoptions), + constint:third(atoptions), + acceptformal:fourth(atoptions), + sbdisp:fifth(atoptions) + ), + + /* If we haven't explicitly got a displayed expression for feedback then generate one. */ + if equal(sbdisp, []) then + sbdisp:ev(diff(sb, var), simp), + + ret:[true, RawMark, AnswerNote, FeedBack], + + /* print([sa, sb, sbdisp, constint, var, cont]),*/ + /* SA should be only an expression. */ + if expressionp(sa)=false then + return([false, false, StackAddNote("", "ATInt_SA_not_expression"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]) + else block( + keepfloat:true, + ret:Intfun(sa, sb, sbdisp, constint, acceptformal, var) + ), + simp:oldsimp, + return(ret) + )$ + +/* This function sorts out the possible option combinations for the answer test, checks them and + returns them in a known consistent way. + Options currently are as follows: + [NOCONST, FORMAL, spdisp] + where + NOCONST = true or false. Are we strict in requiring a constant of integration? + FORMAL = true or false. Are allow anything which is the formal derivative. + sbdisp = ?, any expression which the teacher wants to display instead of an auto-generated derivative of the teacher's answer. + Other options can be added as needed. + */ +ATIntOptions(opts) := block([note, var, atopts, optdefaults], + note:"", + /* Add in default values for the options here. See ATIntOptionsHelper for details.*/ + optdefaults:[true, false, []], + if emptyp(opts) or not(is(length(opts)<5)) then return(["ATInt_STACKERROR_OptList", x, 0, true]), + var:first(opts), + atopts:setify(rest(opts)), + if elementp(NOCONST, atopts) then block( + atopts:setdifference(atopts,{NOCONST}), + optdefaults[1]:false + ), + if elementp(FORMAL, atopts) then block( + atopts:setdifference(atopts,{FORMAL}), + optdefaults[2]:true + ), + /* If there is a display expression, then use it. */ + if not(emptyp(atopts)) then optdefaults[3]:first(listify(atopts)), + return(append([note,var], optdefaults)) +)$ + +Intfun(SA, SB, SBdisp, constint, acceptformal, var) := block([val,rawmk,ansnote,fb,ret,ex,SAd,SBd,SBraw,saa,dd,dc,lSAv,lSBv,mSAv,mSBv,SAConsistentLogs,SAUsedLogAbs,SBUsedLogAbs], + val:true, rawmk:false, fb:"", ansnote:"", + ret:[val, rawmk, ansnote, fb], + /* Check if the teacher and student used only log abs. + Teacher must be consistent, otherwise the student doesn't have to be!*/ + SAUsedLogAbs:ATInt_logabs_p(SA, var), + SBUsedLogAbs:ATInt_logabs_p(SB, var), + /* Did the teacher have any logs?! */ + if freeof(log, SB) then + SBUsedLogAbs:false, + if debug then print(["Original expressions: ", SA, SB]), + if debug then print(["Used Logabs?: ", SAUsedLogAbs, SBUsedLogAbs]), + /* This expands out logarithms for constants, e.g. ln(k*|x|) */ + SB:ev(SB, logexpand:super, simp), + if debug then print(["Expanded any log constants in the teacher's answer? ", SA, SB]), + /* This strips off any trailing constant of integration from the teacher's answer */ + SB:strip_int_const(SB, var), + /* This strips off any trailing constant of integration from the student's answer */ + SAa:strip_int_const(ev(SA, logexpand:super, simp), var), + if debug then print(["Striped off constants of integration: ", SA, SB]), + /* If the teacher has not used logabs, then strip out any logabs from the student's answer. */ + /* Student consistency is a different issue. */ + SAConsistentLogs:ATInt_consistent_logabs_p(SA, var), + if not(SBUsedLogAbs) then ( + SA:subst(STACKLA=log, ATInt_logabs_to_STACKLA(SA)), + SAa:subst(STACKLA=log, ATInt_logabs_to_STACKLA(SAa)) + ), + /* Calculate derivatives */ + SAd:ev(diff(SA, var), simp), + SBd:ev(diff(SB, var), simp), + if debug then print([SAa, SBd]), + if debug then print(["Derivatives : ", SAd, SBd]), + if ev(algebraic_equivalence(SAd, SBd), simp) then block( + /* Check for constant of integration - code copied from algebraic_equivalence. */ + ex:errcatch(ev(fullratsimp(SA-SB), simp, trigexpand:true, logexpand:super, keepfloat:true)), + if ex=[] then (return([false, false, "ATInt: simplification failed.", StackAddFeedback("", "ATInt_generic", stack_disp(SBdisp, "d"), stack_disp(var, "i"), stack_disp(SAd, "d"))])), + ex:ex[1], + ex:ev(trigsimp(ex), simp), + ex:ev(trigreduce(ex), simp), + if debug then print(["Simplified difference: ", ex]), + dd:ev(float(ex), simp), + dc:numberp(dd) and dd#0.0, + if ex=0 then + if constint then + (rawmk:false, fb:StackAddFeedback("", "ATInt_const"), ansnote:StackAddNote("", "ATInt_const")) + else + (rawmk:true, ansnote:StackAddNote("", "ATInt_const_condone")) + else if dc then + if constint then + (rawmk:false, fb:StackAddFeedback("", "ATInt_const_int"), ansnote:StackAddNote("", "ATInt_const_int")) + else + (rawmk:true, ansnote:StackAddNote("", "ATInt_const_int_condone")) + else if freeof(log, SA) or freeof(log, SB) then + if ATIntWeirdConstp(ex, var) then + (rawmk:false, fb:StackAddFeedback("", "ATInt_weirdconst"), ansnote:StackAddNote("", "ATInt_weirdconst")) + else if constint and listofvars(ex)=[var] then + (rawmk:false, fb:StackAddFeedback("", "ATInt_const"), ansnote:StackAddNote("", "ATInt_const")) + else + (rawmk:true, ansnote:StackAddNote("", "ATInt_true")) + /* From this point onwards we *have logarithms*. */ + else if ev(algebraic_equivalence(SA, SB), simp) then + (rawmk:false, fb:StackAddFeedback("", "ATInt_const"), ansnote:StackAddNote("", "ATInt_const_equiv")) + else if ev(algebraic_equivalence(SAa, SB), simp) then + (rawmk:true, ansnote:StackAddNote("", "ATInt_true_equiv")) + else if freeof(var, ex) and not(ATIntWeirdConstp(ex, var)) then + (rawmk:true, ansnote:StackAddNote("", "ATInt_true_differentconst")) + else + (rawmk:acceptformal, fb:StackAddFeedback("", "ATInt_EqFormalDiff"), ansnote:StackAddNote("", "ATInt_EqFormalDiff")) + ) else /* Check for the special cases where the buggy rule is true. */ + if ev(algebraic_equivalence(SAa, ev(diff(SBd, var), simp)), simp) and ev(algebraic_equivalence(exp(x), SBd), simp)#true then + (rawmk:false, fb:StackAddFeedback("", "ATInt_diff"), ansnote:StackAddNote("", "ATInt_diff")) + else + (rawmk:false, fb:StackAddFeedback("", "ATInt_generic", stack_disp(SBdisp, "d"), stack_disp(var, "i"), stack_disp(SAd, "d")), ansnote:StackAddNote("", "ATInt_generic")), + /* Has the student used log(x) vs log(abs(x)) in their answer? */ + if not(SAUsedLogAbs) and SBUsedLogAbs then + (rawmk:false, fb:StackAddFeedback(fb, "ATInt_logabs"), ansnote:StackAddNote(ansnote, "ATInt_logabs")), + /* Has the student been inconsistent in using log(x) vs log(abs(x)) in their answer? */ + if not(SAConsistentLogs) then + (rawmk:false, fb:StackAddFeedback("", "ATInt_logabs_inconsistent"), ansnote:StackAddNote(ansnote, "ATInt_logabs_inconsistent")), + lSAv:listofvars(SA), + lSAv:listofvars(SA), + lSBv:listofvars(SB), + mSAv:member(var, lSAv), + mSBv:member(var, lSBv), + if not(mSBv) then ( + if mSAv then + ansnote:StackAddNote(ansnote, "ATInt_var_SA_notSB") + else if not(listscontain(lSAv, lSBv, v)) and not(listsoverlap(lSAv, lSBv)) then + ansnote:StackAddNote(ansnote, "ATInt_var_notSASB_SAnceSB") ) /* var not in SA or SB, and no variable common to SA and SB */ + else if not(mSAv) then + if mSBv then + ansnote:StackAddNote(ansnote, "ATInt_var_SB_notSA"), + + ret:[val, rawmk, ansnote, fb], + return(ret) +)$ + +/* This function decides if the constant of integration looks "weird".*/ +ATIntWeirdConstp(ex, var):=block([l], + /* Don't bother looking for a wierd constant if the variable is still there. */ + if not(freeof(var, ex)) then return(false), + l:listofvars(ex), + if length(l)#1 then return(true), + if degree(ex, first(l))#1 then return(true) + else return(false) +)$ + +/* Checks all occurances of v are inside abs, e.g. abs(v) */ +ATInt_var_in_abs_p(ex, var):=block( + if ex=var then return(false), /* var on its own is not inside abs() */ + if atom(ex) then return(true), + if freeof(var, ex) then return(false), /* if we don't have var then it is not inside abs() */ + if safe_op(ex) = "abs" then return(true), + apply("and", maplist(lambda([ex2], ATInt_var_in_abs_p(ex2, var)), args(ex))) +)$ + +/* Check if all occurances of the variable v, which are inside a log function, are protected by abs() */ +ATInt_logabs_p(ex, var):=block( + if atom(ex) then return(true), + if safe_op(ex) = "log" then return(apply("and", maplist(lambda([ex2], ATInt_var_in_abs_p(ex2, var)), args(ex)))), + apply("and", maplist(lambda([ex2], ATInt_logabs_p(ex2, var)), args(ex))) +)$ + +/* Transform log(abs(ex)) to a single dummy function STACKLA(ex) + This enables us to strip them out. This will not catch all cases, e.g. log(k*abs(x)) isn't caught here... +*/ +ATInt_logabs_to_STACKLA(ex):=block( + if atom(ex) then return(ex), + if safe_op(ex) = "log" then ( + if atom(first(args(ex))) then + return(ex) + else if safe_op(first(args(ex))) = "abs" then + return(STACKLA(first(args(first(args(ex)))))) + ), + return(apply(op(ex),maplist(ATInt_logabs_to_STACKLA,args(ex)))) +)$ + +/* Has the student been consistent in using log(abs(ex))? */ +/* We need to check for the integration variable, inside logarithm functions. */ +/* We don't want things like log(3) to "look like" a log here. */ +ATInt_consistent_logabs_p_helper(ex, var):=block( + if atom(ex) then return(0), + if safe_op(ex) = "log" and ATInt_var_in_abs_p(ex, var) then return(STACKLOGABS), + if safe_op(ex) = "log" and member(var, listofvars(args(ex))) then return(STACKLOG), + return(apply("+", maplist(lambda([ex1], ATInt_consistent_logabs_p_helper(ex1, var)), args(ex)))) +); + +ATInt_consistent_logabs_p(ex, var):=block([helper], + helper:ev(ATInt_consistent_logabs_p_helper(ex, var), simp), + helper:listofvars(helper), + if member(STACKLOG, helper) and member(STACKLOGABS, helper) then false else true +); + +/* Look over an expression and find all the variables wrt which we are integrating. */ +ATIntGetVar(ex):= block( + if atom(ex) then return([]), + if safe_op(ex)="int" then return([second(args(ex))]), + flatten(map(ATIntGetVar, args(ex))) +); + +/********************************************************************/ +/* An answer test for differentiation questions. */ +/* sa is the students' answer, */ +/* sbl is a list consisting of (1) the answer, and (2) the variable */ +/********************************************************************/ +ATDiff(sa, sb, so) := + block([old_simp, keepfloat, RawMark, FeedBack, AnswerNote, ret, str, da, db, dd, dc, var, cont, SAA, SBB, SOO], + old_simp:simp, simp:false, RawMark:false, FeedBack:"", AnswerNote:"", + keepfloat:true, + + SAA:errcatch(ev(sa, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then return([false,false,StackAddNote("","ATDiff_STACKERROR_SAns"),""]), + SBB:errcatch(ev(sb, simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then return([false,false,StackAddNote("","ATDiff_STACKERROR_TAns"),""]), + SOO:errcatch(ev(so, simp, nouns)), + if (is(SOO=[STACKERROR]) or is(SOO=[])) then return([false,false,StackAddNote("","ATDiff_STACKERROR_Opt"),""]), + + /* We always simplify the teacher's answer. */ + sb:first(SBB), + + /* SA should be only an expression. */ + if expressionp(sa)=false then + return([false,false,StackAddNote("","ATDiff_SA_not_expression"),StackAddFeedback("","ATAlgEquiv_SA_not_expression")]) + else block( + keepfloat:true, + ret:Difffun(sa, sb, so) + ), + simp:old_simp, + return(ret) +)$ + +Difffun(SA, SB, v) := block([val, rawmk, ansnote, fb, ret, lSAv, lSBv, mSAv, mSBv], + val:true, rawmk:false, fb:"", ansnote:"", + ret:[val, rawmk, ansnote, fb], + if algebraic_equivalence(SA, SB) then + (rawmk:true, ansnote:StackAddNote("", "ATDiff_true")) + else + if ev(algebraic_equivalence(diff(SA,v), int(SB,v)), simp) then ( + rawmk:false, + ansnote:StackAddNote("", "ATDiff_int"), + fb:StackAddFeedback("", "ATDiff_int") + ) else ( + lSAv:listofvars(SA), + lSBv:listofvars(SB), + mSAv:member(v, lSAv), + mSBv:member(v, lSBv), + if not(mSBv) then ( + if mSAv then + ansnote:StackAddNote(ansnote, "ATDiff_var_SA_notSB") + else if not(listscontain(lSAv, lSBv, v)) and not(listsoverlap(lSAv, lSBv)) then + ansnote:StackAddNote(ansnote, "ATDiff_var_notSASB_SAnceSB") ) + /* Not in SA or SB, and no variable common to SA and SB. */ + else if not(mSAv) then ( + if mSBv then + ansnote:StackAddNote(ansnote, "ATDiff_var_SB_notSA") + ) + ), + ret:[val, rawmk, ansnote, fb], + return(ret) +)$ + +/* Look over an expression and find all the variables wrt which we are differentiating. */ +ATDiffGetVar(ex):= block( + if atom(ex) then return([]), + if safe_op(ex)="diff" then return([second(args(ex))]), + flatten(map(ATDiffGetVar, args(ex))) +)$ + +/* ****************************************************** */ +/* */ +/* The assess function takes two expressions, ex1 and ex2 */ +/* */ +/* It returns the name of the *strictest* sense in which */ +/* they are considered to be the "same" */ +/* */ +/* ****************************************************** */ + +assess(ex1,ex2):=block([ret], + + SAA:errcatch(ev(SA, simp, nouns)), + if (is(SAA=[STACKERROR]) or is(SAA=[])) then return([false,false,"assess_STACKERROR_SAns",""]), + SBB:errcatch(ev(SBL,simp, nouns)), + if (is(SBB=[STACKERROR]) or is(SBB=[])) then return([false,false,"assess_STACKERROR_TAns",""]), + + ret:ATCASEqual(ex1,ex2), + if ret[2] then return("ATCASEqual"), + + ret:ATEqualComAss(ex1,ex2), + if ret[2] then return("ATEqualComAss"), + + ret:ATAlgEquiv(ex1,ex2), + if ret[2] then return("ATAlgEquiv"), + + ret:ATSubstEquiv(ex1,ex2), + if ret[2] then return("ATSubstEquiv"), + + ret:ATSameType(ex1,ex2), + if ret[2] then return("ATSameType"), + + return("") +)$ + +/* ****************************************************** */ +/* */ +/* Tables */ +/* */ +/* ****************************************************** */ + +/* A function to create a truth table of an expression ex. */ +truth_table(ex) := block([exs, vars, tab, tt], + vars: ev(sort(listofvars(ex)),simp), + if length(vars) > 5 then error("truth_table will only print with fewer than 6 variables."), + /* Store this variable to prevent 2^n re-evaluations of this function. */ + exs: noun_logic_remove(ex), + tab: maplist(lambda([ex2], zip_with("=", vars, ex2)), truth_table_allvars(vars)), + tab: maplist(lambda([ex2], append(maplist(rhs, ex2), [ev(logic_simp(exs), ex2)])), tab), + tab: append([append(vars, [ex])], tab), + apply(table, tab) +)$ + +truth_table_allvars(l) := block( + if emptyp(l) then return([[]]), + return(append( maplist(lambda([ex], append([false], ex)), truth_table_allvars(rest(l))), + maplist(lambda([ex], append([true], ex)), truth_table_allvars(rest(l))))) +)$ + +/* This variable controls whether boolean true/false are abbreviated to T/F respectivley when printing tables. */ +table_bool_abbreviate:true$ +table_bool_abbreviate_fn(ex):= block( + if safe_op(ex) = "texcolor" then return(sconcat("\\color{", first(args(ex)), "}{\\underline{", table_bool_abbreviate_fn(second(args(ex))), "}}")), + if table_bool_abbreviate=true then + return(if ex=true then "\\mathbf{T} " else if ex=false then "\\mathbf{F} " else stack_disp(ex, "")) + else stack_disp(ex, "") +)$ + +table_tex(ex):= block([ret, astart], + /* Make a header. */ + astart: ev(makelist("c", k, length(first(ex))), simp), + astart: sconcat("\\begin{array}{", simplode(astart, "|"), "} "), + ret: matrixmap(table_bool_abbreviate_fn, apply(matrix, args(ex))), + ret: maplist(lambda([ex2], simplode(ex2, " & ")), args(ret)), + rest:sconcat(astart, first(ret), "\\\\ \\hline ", simplode(rest(ret), " \\\\ "), "\\end{array} ") +)$ +texput(table, table_tex)$ + +table_zip_with(fn, T1, T2) := block( + apply(table, zip_with(lambda([ex1,ex2], zip_with(fn,ex1,ex2)), args(T1), args(T2))) +)$ + +table_difference(T1, T2) := table_zip_with(lambda([ex1,ex2], if ex1=ex2 then ex1 else texcolor("red", ex1)), T1, T2)$ + +/* ****************************************************** */ +/* */ +/* Trees */ +/* */ +/* ****************************************************** */ +disptree(e) := sconcat("
  • ", tree_rec(e), "
"); + +/* A list of functions which should use the TeX representation. (Defined as a list to be user-editable) */ + +tree_texlist:{"#pm#", "%union", "%intersection"}; +tree_rec(e) := block([treelist], + /* We don't need to wrap strings in LaTeX and unwrap them later in this display function! */ + if stringp(e) then return(sconcat("", e ,"")), + if atom(e) then return(sconcat("", stack_disp(e, "i") ,"")), + if is(safe_op(e)="treestop") then return(sconcat("", stack_disp(first(e), "i") ,"")), + if is(safe_op(e)="matrix") then return(sconcat("", stack_disp(e, "i") ,"")), + if is(safe_op(e)="binomial") then return(sconcat("", stack_disp(e, "i") ,"")), + if is(safe_op(e)="disp_parens") then return(tree_rec(first(ex))), + + treelist:flatten(["", op(noun_logic_remove(e)), "
    ", map(lambda([ex], sconcat("
  • ", tree_rec(ex) ,"
    • ")), args(e)), "
"]), + + /* Lots of opportunities/need for fine-tuning. */ + + if is(safe_op(e)="int") then treelist:flatten(["\\(\\int \\cdots \\mathrm{d}", stack_disp(second(e), ""), " \\)
  • ", tree_rec(first(e)), "
"]), + if is(safe_op(e)="diff") then treelist:flatten(["\\(", stack_disp(apply(noundiff, append([NULLNUM], rest(args(e)))), ""), " \\)
  • ", tree_rec(first(e)), "
"]), + if is(safe_op(e)="sum" or safe_op(e)="'sum") then treelist:flatten(["\\(\\sum_{", stack_disp(second(e), ""), "=", stack_disp(third(e), ""), "}^{", stack_disp(fourth(e), ""), "} \\cdots \\)
  • ", tree_rec(first(e)), "
"]), + if is(safe_op(e)="limit" or safe_op(e)="'limit") then treelist:flatten(["\\(\\lim_{", stack_disp(second(e), ""), "\\rightarrow{", stack_disp(third(e), ""), "}} \\cdots \\)
  • ", tree_rec(first(e)), "
"]), + /* This example mirrors tex-gamma. */ + if is(safe_op(e)="gamma") then treelist:flatten(["\\(\\Gamma\\)
  • ", tree_rec(first(e)), "
"]), + /* This example mirrors tex-sqrt. */ + if is(safe_op(e)="sqrt") then treelist:flatten(["\\(\\sqrt{}\\)
  • ", tree_rec(first(e)), "
"]), + + if elementp(safe_op(e), tree_texlist) or logicp(e) then block( + /* Apply the operator to as many arguments as we have, none of which print. */ + treelist:["\\(", stack_disp(apply(op(e), ev(makelist(NULLNUM,k,1,length(args(e))),simp)), ""), "\\)"], + /* Try to get a symbol from the tex database, to avoid empty brackets round functions. */ + if symbolp(op(e)) then block([%_do], + if not(stringp(%_do:get_texword(op(e)))) then %_do:get_texsym(op(e)), + treelist:["\\(", %_do, "\\)"] + ), + treelist:flatten(append(treelist, ["
    ", map(lambda([ex], sconcat("
  • ", tree_rec(ex) ,"
    • ")), args(e)), "
"])) + ), + + apply(sconcat, treelist) +)$ + + +/* ****************************************************** */ +/* */ +/* End of file processes */ +/* */ +/* ****************************************************** */ +/* Slight hack to compile these functions and hence suppress warnings. */ +load(linearalgebra); + +/* Initialise the language-code delivery, for special cases. */ +%_STACK_LANG: "en"$ +is_lang(code):=ev(is(%_STACK_LANG=code),simp=true)$ + +/* Stack expects some output with the version number the output happens at */ +/* maximalocal.mac after additional library loading */ +stackmaximaversion:2024060300$ diff --git a/stack/2024060300/maxima/stackreporting.mac b/stack/2024060300/maxima/stackreporting.mac new file mode 100644 index 0000000..14f9dd7 --- /dev/null +++ b/stack/2024060300/maxima/stackreporting.mac @@ -0,0 +1,27 @@ +/* ****************************************************** */ +/* */ +/* Reporting functions */ +/* */ +/* ****************************************************** */ + +STACKanalysis(A):=block([l0, l1, l2, l3], + l0:maplist(ineqorder, A), + l1:listify(setify(fullratsimp(l0))), + l2:maplist(lambda([ex], setify(sublist(A, lambda([ex2], second(ATAlgEquiv(ex2,ex)))))), l1), + l3:maplist(lambda([ex], length(sublist(A, lambda([ex2], second(ATAlgEquiv(ex2,ex)))))), l1), + transpose(matrix(l1, l2, l3)) +)$ + +/* This is an example function which takes a list "l" and returns the equivalence classes for the data. */ +/* Any of the other STACK answer test functions can be used here in place of ATAlgEquiv. */ +stack_equiv_classes(l):=block( + equiv_classes(setify(l), lambda([x, y], second(ATAlgEquiv(x, y)))) +); + +/* This need to be implemented in the future. */ +stack_analysis(ex):=block( + error("stack_analysis: this function has not yet been implemented. Please see the maxima code directly for examples of how to analyse data."), + false +)$ + +simp:false; diff --git a/stack/2024060300/maxima/stackstrings.mac b/stack/2024060300/maxima/stackstrings.mac new file mode 100644 index 0000000..585ac1f --- /dev/null +++ b/stack/2024060300/maxima/stackstrings.mac @@ -0,0 +1,480 @@ +/* Various string processing tools, primarily for parsing and generating JSON. */ + + +/* First some functions for dealing with stack_maps. */ + +/* A map is a list of key value pairs with the first element being the string "stack_map" */ +/* We intentionally skip the use of structs to allow people to directly process the "map" */ +/* from within STACK question code as structs were still forbidden there at the time. */ +/* Also avoiding certain list convenience functions as they are quite recent additions */ +/* to Maxima, so do not wonder why things are done at quite a low level. */ +is_stackmap(x) := ev(listp(x) and is(length(x)>0) and is(x[1]="stack_map"), simp)$ +/* might as we be called stackmapp() but that sounds odd. */ +stackmapp(x) := is_stackmap(x)$ + +stackmap_get(m, k) := block([], + if not is_stackmap(m) then return(und), + return(assoc(k,rest(m,1),und)) +)$ + +/* Either take the value from the map, or use the value of the atom. */ +stackmap_get_ifexists(m, k) := block([], + if not is_stackmap(m) then return(m), + return(assoc(k,rest(m,1),und)) +)$ + +stackmap_set(m, k, v) := block([], + /* If we are given anything else than a map as the map we make a new map. */ + if not is_stackmap(m) then return(["stack_map",[k,v]]), + /* Find all others. */ + return(append(["stack_map"],sublist(rest(m,1), lambda([x],is(x[1]#k))),[[k,v]])) +)$ + +stackmap_unset(m, k) := block([], + if not is_stackmap(m) then return(und), + return(append(["stack_map"],sublist(rest(m,1), lambda([x],is(x[1]#k))))) +)$ + +stackmap_keys(m) := block([], + if not is_stackmap(m) then return(und), + return(map(lambda([x], x[1]), rest(m,1))) +)$ + +stackmap_values(m) := block([], + if not is_stackmap(m) then return(und), + return(map(lambda([x], x[2]), rest(m,1))) +)$ + +stackmap_has_key(m, k) := block([tmp, found], + found: false, + if not is_stackmap(m) then return(false), + for tmp in rest(m,1) do (if is(tmp[1]=k) then (found:true,break)), + return(found) +)$ + + +/* This function takes a string containing JSON and returns a list, number, string, */ +/* boolean or a stackmap depending on what if finds. Should it find null or empty */ +/* input it returns und. */ +/* Note that we do use stringproc. */ +stackjson_parse(json) := block([r,tmp,tokens,mode,i,lastslash,c,starts,nt,k,v,dm], + r: und, + if not stringp(json) or is(json="") then return(und), + tmp:strim(sconcat(ascii(32),ascii(9),ascii(10),ascii(11),ascii(12),ascii(13)),json), + if is(tmp="") then return(und), + + /* Easy ones. */ + if is(tmp="true") then return(true), + if is(tmp="false") then return(false), + if is(tmp="null") then return(und), + if is(tmp="[]") then return([]), + if is(tmp="{}") then return(["stack_map"]), + + /* Not easy, do some tokenising. */ + mode:"raw", /* In a string or not, maybe number */ + i:0, + tokens:[], + lastslash:false, + while ev(is(i0), simp) do ( + r:[], + nt:[], + i:1, + /* Change this to actual sublist as this is not the way to do it... */ + while ev(is(i20), simp) then return(und), + starts:sublist_indices(tokens, lambda([x], is(x=_stackjson_tokens_list_open) or is(x=_stackjson_tokens_dict_open))) + ), + /* At this point the tokens list has been reduced to length of one or things are broken... */ + return(tokens[1]) +)$ + +/* Takes a string that is assumed to be hexadecimal and turns it to an integer the hard way. */ +/* Returns interesting things if the input is not hexadecimal... */ +stack_string_hex_to_num(hexstring) := block([c, tmp], + c:0, + for tmp in charlist(sdowncase(hexstring)) do c:c*16+(sposition(tmp,"0123456789abcdef")-1), + return(ev(c, simp)) +)$ + +/* Takes a string representing an integer or a float and parses it the hard way to avoid having to eval it. */ +/* probably sensitive to large exponents */ +stack_string_parse_number(somestring) := block([c, b, phase, neg,nege, tmp, i], + neg:false, + nege:false, + c:0, + phase:"left of dot", + i:0, + b:0, + for tmp in charlist(sdowncase(somestring)) do ( + if is(phase="left of dot") then ( + if is(tmp=".") then (phase:"right of dot", i:-1) + elseif is(tmp="-") then neg:true + elseif is(tmp="+") then neg:false + elseif digitcharp(tmp) then c:c*10+(cint(tmp)-48) + elseif is(tmp="e") then phase:"exponent" + ) elseif is(phase="right of dot") then ( + if digitcharp(tmp) then (c:c+((cint(tmp)-48)*10^i),i:i-1) + elseif is(tmp="e") then phase:"exponent" + ) elseif is(phase="exponent") then ( + if is(tmp="-") then nege:true + elseif is(tmp="+") then nege:false + elseif digitcharp(tmp) then b:b*10+(cint(tmp)-48) + ) + ), + if is(phase="exponent") then if nege then c:c*10^-b else c:c*10^b, + c:ev(c, numer, simp), + if neg then return(-c), + return(c) +)$ + +stackjson_protect_escapes(c) := if c = "\\" then "\\\\" + else if c = "\"" then "\\\"" + else if c = ascii(8) then "\\b" + else if c = ascii(9) then "\\t" + else if c = ascii(10) then "\\n" + else if c = ascii(12) then "\\f" + else if c = ascii(13) then "\\r" + else c$ + +/* Takes pretty much anything and turns it to a JSON string */ +stackjson_stringify(obj) := block([tmp,r,l], + r:und, + if is(obj=und) then r:"null" + else if is(obj=false) then r:"false" + else if is(obj=true) then r:"true" + /* In the string case we do the following.*/ + /* 1. Create a character list and protect escapes on each character. */ + /* 2. Split the character list into batches of size 64 (maximum function argument limit in GCL). */ + /* 3. Loop through each batch. */ + /* 3a. Pass each batch to `sconcat` to create a batch string of length 64. */ + /* 3b. Successively `sconcat` each batch on to the result string. */ + /* Note that this can be achieved in a simpler way by using `simplode`, which was the case in the prior code. */ + /* Prior code: `r : sconcat("\"",simplode(map(stackjson_protect_escapes, charlist(obj))),"\"")` */ + /* However, there is evidence showing that this code is quadratic and that the batch optimisation helps to alleviate this. */ + /* See here: https://docs.stack-assessment.org/en/Developer/Optimising_STACK_for_large_Maxima_variables/ for more details. */ + else if stringp(obj) then block([char_list], + /* Create character list with escapes protected */ + char_list: map(stackjson_protect_escapes, charlist(obj)), + /* Set batch size to 64, which is inferred from the maximum function argument limit in GCL-compiled Lisp. Other compilations (e.g., SBCL) are less limited in this respect. */ + batch_size: 64, + /* Start the return string */ + r: "\"", + /* Calculate the number of batches */ + l : ev(ceiling(length(char_list)/batch_size), simp), + /* Loop through the batches */ + i : 1, + while (ev(i <= l, simp)) do ( + batch: [], + j: 1, + /* Create the batch by looping through the character list and push-popping */ + while (ev(j <= batch_size and not emptyp(char_list), simp)) do ( + push(pop(char_list), batch), + j: ev(j+1, simp) + ), + /* Pass the batch to sconcat, and then append the resultant batch string to the return string */ + /* Note that reverse is required due to the push-popping when creating the batch */ + r: sconcat(r, apply(sconcat, reverse(batch))), + i: ev(i + 1, simp) + ), + /* End the return string */ + r: sconcat(r, "\"") + ) else if is_stackmap(obj) then ( + l:[], + for tmp in stackmap_keys(obj) do l:append(l,[sconcat(stackjson_stringify(tmp),":",stackjson_stringify(stackmap_get(obj,tmp)))]), + r:sconcat("{",simplode(l,","),"}") + ) else if listp(obj) and length(obj) > 0 then r:sconcat("[",simplode(makelist(stackjson_stringify(x),x,obj),","),"]") + else if listp(obj) then r:"[]" + else if integerp(ev(obj,simp)) then r:string(ev(obj,simp)) + else if numberp(ev(float(obj),simp)) then r:string(float(ev(float(obj),simp))) + else r:stackjson_stringify(string(obj)), + return(r) +)$ + + +/** + * Special tools for dealing with CASText2. + * + * These tools are very advanced and probably not for a novice author. + * Essentially, these are useful if one generates CASText2 values inside + * keyval-fields and/or stores them into the state in Stateful. + * The only real use for a raw CASText2 value is to be outputted + * by the castext-block within castext itself. + * + * Note that while it is possible to manually construct a CASText2 + * value the preferred way is to use the compiler logic and just + * write normal, although escaped, CASText inside a Maxima-string + * and let the compiler deal with it. + */ +/** + * Condenses the result of a CASText2 expression. Speeds PHP-side + * parsing and lessens the transferred bytes. + */ +castext_simplify(ct2) := block([_r,_i,_t,_redo], + if stringp(ct2) then return(ct2), + if listp(ct2) then ( + _i:0, + _redo:false, + _r:[ct2[1], castext_simplify(ct2[2])], + if is(ct2[1]="%root") then _i:2, + /* We especially want to try to simplify jsxgraph-block content. + * It is likely to be highly fragmented with plenty of injections. + * That block now maps to the `iframe` block. + */ + if is(ct2[1]="iframe") then (_i:3, _r: append(_r,[castext_simplify(ct2[3])])), + if is(_i>0) then ( + if listp(last(_r)) and is(last(_r)[1]="%root") then ( + _redo: true, + _r : append(firstn(_r, ev(length(_r) - 1, simp)), rest(last(_r))) + ), + while _i < length(ct2) do ( + _i: ev(_i + 1, simp), + _t: castext_simplify(ct2[_i]), + if stringp(_t) and stringp(last(_r)) then ( + _r[length(_r)] : sconcat(last(_r), _t) + ) else if listp(_t) and is(_t[1]="%root") then ( + /* If we do this we may skip simplification of terms. */ + _redo: true, + _r : append(_r, rest(_t)) + ) else ( + _r : append(_r, [_t]) + ) + ), + if is(_r[1]="%root") and is(length(_r)=2) and stringp(_r[2]) then ( + return(_r[2]) + ), + if _redo then return(castext_simplify(_r)), + return(_r) + ) + ), + return(ct2) +)$ + +/** + * A concat for castext2. If you need to concat more terms lreduce... + */ +castext_concat(a, b) := block([_tmp, _a, _b], + _a: castext_simplify(a), + _b: castext_simplify(b), + if stringp(_a) and stringp(_b) then return(sconcat(_a, _b)), + return(castext_simplify(["%root", _a, _b])) +)$ + +/** + * For now we include this as a predicate function not a full answer test. + */ +regex_match_exactp(regex, str) := block([l1, bool1], + l1:regex_match(regex, str), + bool1:listp(l1), + if bool1 then block([strmatch], + strmatch:first(l1), + bool1:sequal(str, strmatch) + ), +return(bool1))$ + +/* STACK csv-helpper special tool for file output generation. + * Generates a string in CSV format of a list of lists or a matrix + * with an optional list of labels + * Will use normal grind/string style value form output but will return a castext list ["%root", ...] + * with values without Maxima style escapes. Special handling for pure float + * values, with them will use `stackfltfmt` to tune display. + * Uses "-wrapped strings when need be and picks , or ; as the separator + * based on how many values would need to be wrapped. + * We could do this with numericalio but we like to have that float formatting there. + */ +stack_csv_formatter(_data, _labels) := block([_sep,simp,_out,_rowcount,_sepcount1,_sepcount2], + _out:args(_data), + _sepcount1:0, /* for , */ + _sepcount2:0, /* for ; */ + /* Start by joining the values to labels if any */ + if (listp(_labels)) then ( + _out: append([_labels], _out) + ), + + /* Render */ + for _rowcount:1 thru length(_out) do ( + _out[_rowcount]:maplist(lambda([_v],block([_tmp,_wrap], + _tmp: "NULL", + if (stringp(_v)) then ( + _tmp: _v + ) else if ev(numberp(_v) and not integerp(_v), simp) then ( + /* Those special floats, simp for the unary minus. */ + _tmp: stack_disp(_v, "") + ) else ( + _tmp: string(_v) + ), + _wrap: false, + if (integerp(sposition("\"", _tmp))) then ( + _wrap: true, + /* Tricky bit we need to replace " with "" here, so ssubst just won't do. */ + _tmp: simplode(maplist(lambda([c],if is(c="\"") then "\"\"" else c), charlist(_tmp))) + ), + /* If any line changes are in play wrap. */ + if (integerp(sposition(" +", _tmp))) then _wrap: true, + /* If we have special whitespace at the ends of the value we need that wrapping. */ + /* NOTE that the tab on the next line matters. */ + if is(_tmp#strim(" +",_tmp)) then _wrap:true, + + /* Check the separator situation */ + if (not _wrap) then ( + if (integerp(sposition(",", _tmp))) then _sepcount1: _sepcount1+1, + if (integerp(sposition(";", _tmp))) then _sepcount2: _sepcount2+1 + ), + + + if (_wrap) then ( + _tmp: sconcat("\"", _tmp, "\"") + ), + _tmp + )),_out[_rowcount]) + ), + + _sep:"fail", + /* Pick the separator. */ + if _sepcount1 = 0 then ( + _sep: "," + ) else if _sepcount2 = 0 then ( + _sep: ";" + ), + + if sep = "fail" then ( + /* We need to wrap things to allow the use of our separator. */ + _sep: ",", + for _rowcount:1 thru length(_out) do ( + _out[_rowcount]:maplist(lambda([_v],block([_tmp], + _tmp: _v, + if not integerp(sposition("\"", _tmp)) then ( + if integerp(strpos(_sep, _tmp)) then _tmp: sconcat("\"", _tmp, "\"") + ), + _tmp + )),_out[_rowcount]) + ) + ), + + /* TO-DO: do we want to do padding and formatting to help reading in text-editors? */ + + /* Now let's join everything up. */ + _out: maplist(lambda([_row], simplode(_row, _sep)), _out), + _out: simplode(_out," +"), + /* We might want to add a line change to the end. */ + return(["%root", _out]) +)$ + + + +/** + * The logic for turning {@%_val@} to a string, this exists to simplify + * castext2 compilation results. + * %_mode has the following values: + * "i" => sconcat("\({",...,"}\)") or ... for strings + * "im" => sconcat("\\\\\\({",str_to_md(...),"}\\\\\\)") or str_to_md(...) for strings + * "" => ... + * "m" => str_to_md(...) + * Basically the mode tells if we are to wrap things in math-delimiters and if we are in + * markdown mode. + */ +ct2_latex(%_val, %_mode, %_simp):=block([%_tmp,simp], + simp:false, + %_tmp: %_val, + /* Strings */ + if stringp(%_tmp) then ( + /* If in math-mode, i.e. not requesting wrapping wrap with braces. */ + if %_mode = "" or %_mode = "m" then %_tmp: sconcat("{", %_tmp, "}"), + if %_mode = "m" or %_mode = "im" then %_tmp: str_to_md(%_tmp), + return(["smlt", %_tmp]) + ) else if listp(%_tmp) and length(%_tmp) > 0 and is(%_tmp[1] = "%root") then ( + /* If we receive inline CASText then pass it through. */ + if is(length(%_tmp) = 2) then + return(%_tmp[2]), /* Unwrap it as it does not need that wrapping anymore. Unfortunately can only do this for the single elemetn case here. */ + return(%_tmp) + ) else ( + simp: %_simp, + %_tmp: stack_disp(%_tmp, ""), /* Do our own wrapping. */ + %_tmp: sconcat("{", strimr(" ", %_tmp), "}"), + if %_mode = "i" or %_mode = "im" then %_tmp: sconcat("\\(", %_tmp, "\\)") + ), + if %_mode = "m" or %_mode = "im" then ( + %_tmp: str_to_md(%_tmp) + ), + /* Finally give it to PHP side translations. Maybe move them here as well? */ + return(["smlt", %_tmp]) +)$ + diff --git a/stack/2024060300/maxima/stacktex.lisp b/stack/2024060300/maxima/stacktex.lisp new file mode 100644 index 0000000..505c730 --- /dev/null +++ b/stack/2024060300/maxima/stacktex.lisp @@ -0,0 +1,532 @@ +;; Customize Maxima's TEX() function. To give better control to the output. +;; Chris Sangwin 27 Sept 2010. +;; Useful files: +;; \Maxima-5.21.1\share\maxima\5.21.1\share\utils\mactex-utilities.lisp +;; \Maxima-5.21.1\share\maxima\5.21.1\src\mactex.lisp + +;; Additional mactex utilities taken from the distributed file +;; mactex-utilities.lisp +;; Based on code by Richard J. Fateman, copyright 1987. +;; Fateman's code was ported to Common Lisp by William +;; Schelter. + +;; 26 Nov 2017. +;; Note, this commit in Maxmia changed (getcharn f) to (get-first-char). +;; https://sourceforge.net/p/maxima/code/ci/b27acfa194281f42ef6d2a4ef2434d8dea4705f1/ + +;; If you want LaTeX style quotients, first load mactex and second +;; define tex-mquotient as follows + +(defun tex-mquotient (x l r) + (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x))) + (setq l (tex (cadr x) (append l '("\\frac{")) nil 'mparen 'mparen) + r (tex (caddr x) (list "}{") (append '("}") r) 'mparen 'mparen)) + (append l r)) + +;; Define an explicit multiplication +;;(defprop mtimes "\\times " texsym) +;;(defprop mtimes "\\cdot " texsym) + + +;; patch to tex-prefix to make sin(x) always like sin(x), and not the default sin x. +;; CJS 24 June 2004. + +(defun tex-prefix (x l r) + (tex (cadr x) (append l (texsym (caar x)) '("\\left( ") ) (append '(" \\right)") r) 'mparen 'mparen)) + +;; Fix the problem with -27 being printed -(27) +;; CJS 21 Jan 2009 + +(defprop mminus tex-prefix-blank tex) +;;(defprop mminus tex-prefix tex) +(defprop mminus ("-") texsym) + +(defun tex-prefix-blank (x l r) + (tex (cadr x) (append l (texsym (caar x))) r (caar x) rop)) + + +;; Display question marks correctly +(defprop &? ("?") texsym) + +;; Allow colour into TeX expressions from Maxima +;; Thanks to andrej.vodopivec@fmf.uni-lj.si Fri Jan 14 09:32:42 2005 + +(defun tex-texcolor (x l r) + (let + ((front (append '("{\\color{") + (list (stripdollar (cadr x))) + '("}"))) + (back (append '("{\\underline{") + (tex (caddr x) nil nil 'mparen 'mparen) + '("}}}")))) + (append l front back r))) + +(defprop $texcolor tex-texcolor tex) + +;; Allow colour into TeX expressions from Maxima +;; Thanks to andrej.vodopivec@fmf.uni-lj.si Fri Jan 14 09:32:42 2005 + +(defun tex-texcolorplain (x l r) + (let + ((front (append '("{\\color{") + (list (stripdollar (cadr x))) + '("}"))) + (back (append '("{") + (tex (caddr x) nil nil 'mparen 'mparen) + '("}}")))) + (append l front back r))) + +(defprop $texcolorplain tex-texcolorplain tex) + +;; Changed log to ln, and other things. + +(mapc #'tex-setup + '( + (%acos "{\\rm acos}") + (%asin "{\\rm asin}") + (%atan "{\\rm atan}") + + ; Latex's arg(x) is ... ? + (%cos "\\cos ") + (%cosh "\\cosh ") + (%cot "\\cot ") + (%coth "\\coth ") + (%csc "\\csc ") + ; Latex's "deg" is ... ? + (%determinant "\\det ") + (%dim "\\dim ") + (%exp "\\exp ") + (%gcd "\\gcd ") + ; Latex's "hom" is ... ? + (%inf "\\inf ") + ; many will prefer "\\infty". + ; Latex's "ker" is ... ? + ; Latex's "lg" is ... ? + ; lim is handled by tex-limit. + ; Latex's "liminf" ... ? + ; Latex's "limsup" ... ? + (%ln "\\ln ") + (%log "\\ln ") + (%max "\\max ") + (%min "\\min ") + ; Latex's "Pr" ... ? + (%sec "\\sec ") + (%sin "\\sin ") + (%sinh "\\sinh ") + ; Latex's "sup" ... ? + (%tan "\\tan ") + (%tanh "\\tanh ") + ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual + ;(%laplace "{\\cal L}") + + ; Maxima built-in functions which do not have corresponding TeX symbols. + + (%asec "{\\rm asec}") + (%acsc "{\\rm acsc}") + (%acot "{\\rm acot}") + + (%sech "{\\rm sech}") + (%csch "{\\rm csch}") + + (%asinh "{\\rm asinh}") + (%acosh "{\\rm acosh}") + (%atanh "{\\rm atanh}") + + (%asech "{\\rm asech}") + (%acsch "{\\rm acsch}") + (%acoth "{\\rm acoth}") + +)) ;; etc + +;; Remove un-needed {}s from string output. +;; Chris Sangwin, 28/10/2009 + +(defun tex-string (x) + (cond ((equal x "") (concatenate 'string "\\text{ }")) + ((eql (elt x 0) #\\) x) + (t (concatenate 'string "\\text{" x "}")))) + +;; Remove & from the quoted characters. +(defun quote-% (sym) + (quote-chars sym "$%_")) + +;; Chris Sangwin, 21/9/2010 + +(defprop mlessp (" < ") texsym) +(defprop mgreaterp (" > ") texsym) + +;; Change the display of derivatives, at the request of the OU. +;; Chris Sangwin, 1/4/2015. + +(defprop %derivative tex-derivative tex) +(defun tex-derivative (x l r) + (tex (if $derivabbrev + (tex-dabbrev x) + (tex-d x '"\\mathrm{d}")) l r lop rop)) + +(defun tex-d(x dsym) ;dsym should be $d or "$\\partial" + ;; format the macsyma derivative form so it looks + ;; sort of like a quotient times the deriva-dand. + (let* + ((arg (cadr x)) ;; the function being differentiated + (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2) + (ords (if (null (odds difflist 0)) + `(1) + (odds difflist 0) + )) ;; e.g. (1 2), but not empty. + (vars (odds difflist 1)) ;; e.g. (x y) + (numer (mfuncall `$simplify `((mexpt) ,dsym ((mplus) ,@ords)))) ; d^n numerator + (denom (cons '($blankmult) + (mapcan #'(lambda(b e) + `(,dsym ,(simplifya (mfuncall `$simplify `((mexpt) ,b ,(mfuncall `$simplify e))) nil))) + vars ords)))) + (if (symbolp arg) + `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom) + `(($blankmult) ((mquotient) ,numer ,denom) ,arg) + ) + )) + + +(defun tex-dabbrev (x) + ;; Format diff(f,x,1,y,1) so that it looks like + ;; f + ;; x y + (let* + ((arg (cadr x)) ;; the function being differentiated + (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2) + (ords (odds difflist 0)) ;; e.g. (1 2) + (vars (odds difflist 1))) ;; e.g. (x y) + (append + (if (symbolp arg) + `((,arg array)) + `((mqapply array) ,arg)) + (if (and (= (length vars) 1) + (= (car ords) 1)) + vars + `((($blankmult) ,@(mapcan #'(lambda (var ord) + (make-list ord :initial-element var)) + vars ords))))))) + + +;; Change the display of integrals to be consistent with derivatives. +;; Chris Sangwin, 8/6/2015. +(defprop %int tex-int tex) +(defprop %integrate tex-int tex) +(defun tex-int (x l r) + (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integran, at the request of the OU delims / & d + (var (tex (caddr x) nil nil 'mparen rop))) ;; variable + (cond((= (length x) 3) + (append l `("\\int {" ,@s1 "}{\\;\\mathrm{d}" ,@var "}") r)) + (t ;; presumably length 5 + (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen)) + ;; 1st item is 0 + (hi (tex (nth 4 x) nil nil 'mparen 'mparen))) + (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;\\mathrm{d}" ,@var "}") r)))))) + + +;; Fine tune the display to enable us to print gamma07 as \gammma_{07}, +;; Chris Sangwin 7/6/2016. +(defprop $texsub tex-texsub tex) +(defun tex-texsub (x l r) + (let + ((front (append '("{") + (tex (cadr x) nil nil 'mparen 'mparen) + '("}_"))) + (back (append '("{") + (tex (caddr x) nil nil 'mparen 'mparen) + '("}")))) + (append l front back r))) + +;; Powers of functions are displayed by tex as f^2(x), not f(x)^2. +;; This list is an exception, e.g. conjugate(x)^2. +;; We use this list because tex-mexpt is also defined in stacktex40.lisp for earlier versions of Maxima. +(defvar tex-mexpt-fnlist '(%sum %product %derivative %integrate %at $conjugate $texsub $lg $logbase %sqrt + %lsum %limit $pderivop $#pm#)) + +;; insert left-angle-brackets for mncexpt. a^ is how a^^n looks. +(defun tex-mexpt (x l r) + (let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b + ;; here is where we have to check for f(x)^b to be displayed + ;; as f^b(x), as is the case for sin(x)^2 . + ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2. + ;; yet we must not display (a+b)^2 as +^2(a,b)... + ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x + (cond ;; this whole clause + ;; should be deleted if this hack is unwanted and/or the + ;; time it takes is of concern. + ;; it shouldn't be too expensive. + ((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt + (let* + ((fx (cadr x)) ; this is f(x) + (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil] + (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil] + (expon (caddr x)) ;; this is the exponent + (doit (and + f ; there is such a function + (member (get-first-char f) '(#\% #\$)) ;; insist it is a % or $ function + (not (member 'array (cdar fx) :test #'eq)) ; fix for x[i]^2 + ;; Unlike core Maxima we have alist of functions. + (not (member f tex-mexpt-fnlist :test #'eq)) + (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok + (and (atom expon) (numberp expon) (> expon 0)))))) + ; f(x)^3 is ok, but not f(x)^-1, which could + ; inverse of f, if written f^-1 x + ; what else? f(x)^(1/2) is sqrt(f(x)), ?? + (cond (doit + (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen)) + (if (and (null (cdr bascdr)) + (eq (get f 'tex) 'tex-prefix)) + (setq r (tex (cons '(mprogn) bascdr) nil r f 'mparen)) + (setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen)))) + (t nil))))) ; won't doit. fall through + (t (setq l (cond ((or ($bfloatp (cadr x)) + (and (numberp (cadr x)) (numneedsparen (cadr x)))) + ; ACTUALLY THIS TREATMENT IS NEEDED WHENEVER (CAAR X) HAS GREATER BINDING POWER THAN MTIMES ... + (tex (cadr x) (append l '("\\left(")) '("\\right)") lop (caar x))) + ((atom (cadr x)) (tex (cadr x) l nil lop (caar x))) + (t (tex (cadr x) (append l '("{")) '("}") lop (caar x)))) + r (if (mmminusp (setq x (nformat (caddr x)))) + ;; the change in base-line makes parens unnecessary + (if nc + (tex (cadr x) '("^ {-\\langle ") (cons "\\rangle }" r) 'mparen 'mparen) + (tex (cadr x) '("^ {- ") (cons " }" r) 'mminus 'mparen)) + (if nc + (tex x (list "^{\\langle ") (cons "\\rangle}" r) 'mparen 'mparen) + (if (and (integerp x) (< x 10)) + (tex x (list "^")(cons "" r) 'mparen 'mparen) + (tex x (list "^{")(cons "}" r) 'mparen 'mparen))))))) + (append l r))) + +;; Added by CJS, 15-2-24. Display an aligned environmant. +(defprop $aligned tex-aligned tex) + +(defun tex-aligned(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...) + (append l `("\\begin{aligned}") + (mapcan #'(lambda(y) + (tex-list (cdr y) nil (list "\\cr ") "&")) + (cdr x)) + '("\\end{aligned}") r)) + +;; Added by CJS, 10-9-16. Display an argument. +(defprop $argument tex-argument tex) + +(defun tex-argument(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...) + (append l `("\\begin{array}{lll}") + (mapcan #'(lambda(y) + (tex-list (cdr y) nil (list "\\cr ") "&")) + (cdr x)) + '("\\end{array}") r)) + +;; Added by CJS, 15-5-17. Display a list as a group with a single curly bracket on the left. +(defprop $argumentand tex-argumentand tex) +(defun tex-argumentand(x l r) + (append l `("\\left\\{\\begin{array}{l}") + (mapcan #'(lambda(y) + (tex y nil (list "\\cr ") 'mparen 'mparen)) + (cdr x)) + '("\\end{array}\\right.") r)) + +;; ************************************************************************************************* +;; The following code does not affect TeX output, but rather are general functions needed for STACK. +;; + +;; Added 13 Nov 2016. Try to better display trailing zeros. +;; Based on the "grind function". See src/grind.lisp + +;; This function has grind (and hence "string") output the number according to the format template. +;; floatgrind(number, template). +;; DANGER: no error checking on the type of arguments. +(defprop $floatgrind msz-floatgrind grind) +(defun msz-floatgrind (x l r) + (msz (mapcar #'(lambda (l) (get-first-char l)) (makestring (concatenate 'string "floatgrind(" (format nil (cadr (cdr x)) (cadr x)) ",\"" (cadr (cdr x)) "\")"))) l r) +) + +;; This function has grind (and hence "string") output the number with the following number of decimal places. +;; displaydp(number, ndps). +;; DO NOT USE: no error checking on the types of the arguments. +;;(defprop $dispdp msz-dispdp grind) +;;(defun msz-dispdp (x l r) +;; (msz (mapcar #'(lambda (l) (get-first-char l)) (makestring (concatenate 'string "dispdp(" (format nil (concatenate 'string "~," (format nil "~d" (cadr (cdr x))) "f" ) (cadr x)) "," (format nil "~d" (cadr (cdr x))) ")" ))) l r) +;;) + +;; This function has grind (and hence "string") output the number with the following number of decimal places. +;; displaydp(number, ndps). +(defprop $dispdpvalue msz-dispdpvalue grind) +(defun msz-dispdpvalue (x l r) + (msz (mapcar #'(lambda (l) (get-first-char l)) (makestring (format nil (concatenate 'string "~," (format nil "~d" (cadr (cdr x))) "f" ) (cadr x)) )) l r) +) + +;; Define an "arrayp" function to check if we have a Maxima array. +(defmfun $arrayp (x) (and (not (atom x)) (cond ((member 'array (car x) :test #'eq) $true) (T $false)))) + +;; ************************************************************************************************* +;; Added 19 Dec 2018. +;; Based src/mformat.lisp + +;; Suppress warnings printed by mtell, e.g. by solve, rat and other functions. +;; Use the Maxima variable stack_mtell_quiet. +(defun mtell (&rest l) (cond ((eq $stack_mtell_quiet $true) (values)) (t (apply #'mformat nil l)))); + +;; ************************************************************************************************* +;; Added 31 Oct 2019. +;; +;; catchable-syntax-error.lisp +;; copyright 2019 by Robert Dodier +;; I release this work under terms of the GNU General Public License v2 + +;; Helper for MREAD-SYNERR. +;; Adapted from local function PRINTER in built-in MREAD-SYNERR. + +(defun mread-synerr-printer (x) + (cond ((symbolp x) + (print-invert-case (stripdollar x))) + ((stringp x) + (maybe-invert-string-case x)) + (t x))) + +;; Punt to Maxima function 'error' so that syntax errors can be caught by 'errcatch'. +;; This definition replaces the built-in MREAD-SYNERR +;; which throws to the top level of the interpreter in a way which cannot +;; be intercepted by 'errcatch'. +;; +;; After a syntax error is detected, the global variable 'error' +;; contains the error message (which is also printed on the console +;; when the error occurs). +;; +;; Aside from punting to 'error', this implementation doesn't try to +;; do anything else which the built-in MREAD-SYNERR does. In particular +;; this implementation doesn't try to output any input-line information. + +(defun mread-synerr (format-string &rest l) + (let* + ((format-string-1 (concatenate 'string "syntax error: " format-string)) + (format-string-args (mapcar #'mread-synerr-printer l)) + (message-string (apply #'format nil format-string-1 format-string-args))) + (declare (special *parse-stream*)) + (when (eql *parse-stream* *standard-input*) + (read-line *parse-stream* nil nil)) + ($error message-string))) + +;; ************************************************************************************************* +;; Added 08 Jan 2020. +;; Based src/grind.lisp + +;; Up the binding power of mminus, so that -(a/b) outputs exactly this way and not -a/b = (-a)/b. +;; Subtle differences. + +;; In a maxima session type +;; :lisp (defprop mminus 120. rbp); + +;; We provide just two specific functions here, and do not allow users to set an arbitrary binding power. + +;; ************************************************************************************************* + +(defmspec $mminusbp120 (x) + (setq x (car x)) + (defprop mminus 120. rbp) + (defprop mminus 120. lbp) + '$done +) + +(defmspec $mminusbp100 (x) + (setq x (car x)) + (defprop mminus 100. rbp) + (defprop mminus 100. lbp) + '$done +) + +;; ************************************************************************************************* +;; Added 08 Jan 2020. +;; Needed for %union, etc, where we don't display unions of just one item as unions. + +(defprop $%union tex-nary2 tex) +(defprop $%union (" \\cup ") texsym) +;; Sort out binding power of %union to display correctly. +;; tex-support is defined in to_poly_solve_extra.lisp. +(defprop $%union 114. tex-rbp) +(defprop $%union 115. tex-lbp) + +(defprop $%intersection tex-nary2 tex) +(defprop $%intersection (" \\cap ") texsym) +(defprop $%intersection 114. tex-lbp) +(defprop $%intersection 115. tex-rbp) + + +(defun tex-nary2 (x l r) + (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop)) + (cond ((null y) (tex-function x l r t)) ; this should not happen + ((null (cdr y)) (tex (car y) l r lop rop)) ; Single elements in the argument. + (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op))) + ((null (cdr y)) (setq nl (append nl (tex (car y) l r lop rop))) nl) + (setq nl (append nl (tex (car y) l sym lop rop)) + y (cdr y) + l nil)))))) + +;; ************************************************************************************************* +;; Added 4 May 2023. +;; Print all brackets with simp:false; + +;; This is WIP for printing brackets in (a+b)+c. Creates lots of other problems with unary minus. +;; (defun tex (x l r lop rop) +;; ;; x is the expression of interest; l is the list of strings to its +;; ;; left, r to its right. lop and rop are the operators on the left +;; ;; and right of x in the tree, and will determine if parens must +;; ;; be inserted +;; (setq x (nformat x)) +;; (cond ((atom x) (tex-atom x l r)) +;; ((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (>= (tex-lbp rop) (tex-rbp +;; (caar x)))) +;; (tex-paren x l r)) +;; ;; special check needed because macsyma notates arrays peculiarly +;; ((member 'array (cdar x) :test #'eq) (tex-array x l r)) +;; ;; dispatch for object-oriented tex-ifiying +;; ((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r)) +;; (t (tex-function x l r nil)))) + +;; ************************************************************************************************* +;; Added 27 June 2020. +;; Localise some Maxmia-generated strings + +(defprop $true "\\mathbf{!BOOLTRUE!}" texword) +(defprop $false "\\mathbf{!BOOLFALSE!}" texword) + + +;; ************************************************************************************************* +;; Added 20 Feb 2022. +;; Remove %_C and %_E for display purposes. The Maxima function %_ce_rem is defined in utils.mac + +(defmfun $tex1 (x) (reduce #'strcat (tex ($%_ce_rem x) nil nil 'mparen 'mparen))) + +;; ************************************************************************************************* +;; Added 30 May 2022. +;; Allow Maxima to interigate the texword database directly, for words or function names. +;; Copied directly from tex-atom. +(defmfun $get_texword (x) (or (get x 'texword) (get (get x 'reversealias) 'texword))) + +(defmfun $get_texsym (x) (car (or (get x 'texsym) (get x 'strsym) (get x 'dissym) (stripdollar x)))) + +;; ************************************************************************************************* +;; Added 20 Feb 2022. +;; +;; Change the list separation on tex output when commas are used for decimal separators. +;; +;; Code below makes the list separator a normal "texput" concern. +;; E.g. in maxima: texput(stacklistsep, " ; "); +;; (defprop $stacklistsep " , " texword) +;; +;;(defun tex-matchfix (x l r) +;; (setq l (append l (car (texsym (caar x)))) +;; ;; car of texsym of a matchfix operator is the lead op +;; r (append (list (nth 1 (texsym (caar x)))) r) +;; ;; cdr is the trailing op +;; x (tex-list (cdr x) nil r (or (nth 2 (texsym (caar x))) (get '$stacklistsep 'texword)))) +;; (append l x)) + +(defun tex-matchfix (x l r) + (setq l (append l (car (texsym (caar x)))) + ;; car of texsym of a matchfix operator is the lead op + r (append (list (nth 1 (texsym (caar x)))) r) + ;; cdr is the trailing op + x (tex-list (cdr x) nil r (or (nth 2 (texsym (caar x))) (if (string= $stackfltsep '",") '" ; " '" , ")))) + (append l x)) + diff --git a/stack/2024060300/maxima/stacktex40.lisp b/stack/2024060300/maxima/stacktex40.lisp new file mode 100644 index 0000000..ebe670d --- /dev/null +++ b/stack/2024060300/maxima/stacktex40.lisp @@ -0,0 +1,121 @@ +;; Back compatibility with versions of Maxima prior to Maxima 5.41.0 +;; Chris Sangwin 26 Nov 2017. +;; +;; These all involve the change from the old (getcharn f) to (get-first-char). + +;; Note, this commit in Maxmia changed (getcharn f) to (get-first-char). +;; https://sourceforge.net/p/maxima/code/ci/b27acfa194281f42ef6d2a4ef2434d8dea4705f1/ + + +;; insert left-angle-brackets for mncexpt. a^ is how a^^n looks. +(defun tex-mexpt (x l r) + (let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b + ;; here is where we have to check for f(x)^b to be displayed + ;; as f^b(x), as is the case for sin(x)^2 . + ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2. + ;; yet we must not display (a+b)^2 as +^2(a,b)... + ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x + (cond ;; this whole clause + ;; should be deleted if this hack is unwanted and/or the + ;; time it takes is of concern. + ;; it shouldn't be too expensive. + ((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt + (let* + ((fx (cadr x)) ; this is f(x) + (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil] + (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil] + (expon (caddr x)) ;; this is the exponent + (doit (and + f ; there is such a function + (member (getcharn f 1) '(#\% #\$)) ;; insist it is a % or $ function + (not (member 'array (cdar fx) :test #'eq)) ; fix for x[i]^2 + (not (member f tex-mexpt-fnlist :test #'eq)) + (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok + (and (atom expon) (numberp expon) (> expon 0)))))) + ; f(x)^3 is ok, but not f(x)^-1, which could + ; inverse of f, if written f^-1 x + ; what else? f(x)^(1/2) is sqrt(f(x)), ?? + (cond (doit + (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen)) + (if (and (null (cdr bascdr)) + (eq (get f 'tex) 'tex-prefix)) + (setq r (tex (car bascdr) nil r f 'mparen)) + (setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen)))) + (t nil))))) ; won't doit. fall through + (t (setq l (cond ((or ($bfloatp (cadr x)) + (and (numberp (cadr x)) (numneedsparen (cadr x)))) + ; ACTUALLY THIS TREATMENT IS NEEDED WHENEVER (CAAR X) HAS GREATER BINDING POWER THAN MTIMES ... + (tex (cadr x) (append l '("\\left(")) '("\\right)") lop (caar x))) + ((atom (cadr x)) (tex (cadr x) l nil lop (caar x))) + (t (tex (cadr x) (append l '("{")) '("}") lop (caar x)))) + r (if (mmminusp (setq x (nformat (caddr x)))) + ;; the change in base-line makes parens unnecessary + (if nc + (tex (cadr x) '("^ {-\\langle ") (cons "\\rangle }" r) 'mparen 'mparen) + (tex (cadr x) '("^ {- ") (cons " }" r) 'mminus 'mparen)) + (if nc + (tex x (list "^{\\langle ") (cons "\\rangle}" r) 'mparen 'mparen) + (if (and (integerp x) (< x 10)) + (tex x (list "^")(cons "" r) 'mparen 'mparen) + (tex x (list "^{")(cons "}" r) 'mparen 'mparen))))))) + (append l r))) + +;; ************************************************************************************************* +;; Added 2020-01-09 +;; Fix sconcat on versions of Maxima (GCL) prior to 5.41.0 +;; See https://sourceforge.net/p/maxima/code/ci/a7de72db1669deec775dfab6159eb8ca4357b998/ + +;; $sconcat for lists +;; +;; optional: insert a user defined delimiter string +;; +(defun $simplode (li &optional (ds "")) + (unless (listp li) + (gf-merror (intl:gettext "`simplode': first argument must be a list.")) ) + (unless (stringp ds) + (s-error1 "simplode" "optional second") ) + (setq li (cdr li)) + (cond + ((null li) + ($sconcat) ) + ((null (cdr li)) + ($sconcat (car li)) ) + ((string= ds "") + (reduce #'$sconcat li) ) + (t + (do (acc) (()) + (push ($sconcat (pop li)) acc) + (when (null li) + (return (reduce #'(lambda (s0 s1) (concatenate 'string s0 s1)) (nreverse acc) :initial-value ""))) + (push ds acc) )))) + +;; ************************************************************************************************* +;; The following code does not affect TeX output, but rather are general functions needed for STACK. +;; +;; This only works for maxima < 5.41.? + +;; Added 13 Nov 2016. Try to better display trailing zeros. +;; Based on the "grind function". See src/grind.lisp + +;; This function has grind (and hence "string") output the number according to the format template. +;; floatgrind(number, template). +;; DANGER: no error checking on the type of arguments. +(defprop $floatgrind msz-floatgrind grind) +(defun msz-floatgrind (x l r) + (msz (mapcar #'(lambda (l) (getcharn l 1)) (makestring (concatenate 'string "floatgrind(" (format nil (cadr (cdr x)) (cadr x)) ",\"" (cadr (cdr x)) "\")"))) l r) +) + +;; This function has grind (and hence "string") output the number with the following number of decimal places. +;; displaydp(number, ndps). +;; DO NOT USE: no error checking on the types of the arguments. +;;(defprop $dispdp msz-dispdp grind) +;;(defun msz-dispdp (x l r) +;; (msz (mapcar #'(lambda (l) (getcharn l 1)) (makestring (concatenate 'string "dispdp(" (format nil (concatenate 'string "~," (format nil "~d" (cadr (cdr x))) "f" ) (cadr x)) "," (format nil "~d" (cadr (cdr x))) ")" ))) l r) +;;) + +;; This function has grind (and hence "string") output the number with the following number of decimal places. +;; displaydp(number, ndps). +(defprop $dispdpvalue msz-dispdpvalue grind) +(defun msz-dispdpvalue (x l r) + (msz (mapcar #'(lambda (l) (getcharn l 1)) (makestring (format nil (concatenate 'string "~," (format nil "~d" (cadr (cdr x))) "f" ) (cadr x)) )) l r) +) diff --git a/stack/2024060300/maxima/stackunits.mac b/stack/2024060300/maxima/stackunits.mac new file mode 100644 index 0000000..3ddb9cd --- /dev/null +++ b/stack/2024060300/maxima/stackunits.mac @@ -0,0 +1,603 @@ +/* Author Matti Harjula + Aalto University + Copyright (C) 2015 Matti Harjula + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +*/ + + +/****************************************************************/ +/* Simplified tools for handling SI-units (+liters) */ +/* */ +/* Matti Harjula */ +/* */ +/* Answer test added by */ +/* Chris Sangwin */ +/* */ +/* V0.5 August 2016 */ +/****************************************************************/ + +/* This code is commented out as these lists are now defined in the main code in stack/cas/casstring.units.php + which are copied over to maximalocal.mac by the install scripts. This ensures exactly the + same collections of units are available in PHP and this Maxima code. + + stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y], + stack_unit_si_prefix_multiplier:[10^-24, 10^-21, 10^-18, 10^-15, 10^-12, 10^-9, 10^-6, 10^-3, 10^-2, 10^-1, 10, 10^2, 10^3, 10^6, 10^9, 10^12, 10^15, 10^18, 10^21, 10^24], + stack_unit_si_prefix_tex:["\\mathrm{y}", "\\mathrm{z}", "\\mathrm{a}", "\\mathrm{f}", "\\mathrm{p}", "\\mathrm{n}", "\\mu ", "\\mathrm{m}", "\\mathrm{c}", "\\mathrm{d}", "\\mathrm{da}", "\\mathrm{h}", "\\mathrm{k}", "\\mathrm{M}", "\\mathrm{G}", "\\mathrm{T}", "\\mathrm{P}", "\\mathrm{E}", "\\mathrm{Z}", "\\mathrm{Y}"], + stack_unit_si_unit_code:[m, l, L, g, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, A, ohm, C, V, F, S, Wb, T, H, Gy, Sv, lm, lx, mol, M, kat, rad], + stack_unit_si_unit_conversions:[m, m^3/1000, m^3/1000, kg/1000, s, s*3600, 1/s, 1/s, cd, (kg*m)/s^2, kg/(m*s^2), 4.2*J, 4200*J, 1055*J, 1.602177e-19*J, (kg*m^2)/s^2, (kg*m^2)/s^3, A, (kg*m^2)/(s^3*A^2), s*A, (kg*m^2)/(s^3*A), (s^4*A^2)/(kg*m^2), (s^3*A^2)/(kg*m^2), (kg*m^2)/(s^2*A), kg/(s^2*A), (kg*m^2)/(s^2*A^2), m^2/s^2, m^2/s^2, cd, cd/m^2, mol, mol/(m^3/1000), mol/s, rad], + stack_unit_si_unit_tex:["\\mathrm{m}", "\\mathrm{l}", "\\mathrm{L}", "\\mathrm{g}", "\\mathrm{s}", "\\mathrm{h}", "\\mathrm{Hz}", "\\mathrm{Bq}", "\\mathrm{cd}", "\\mathrm{N}", "\\mathrm{Pa}", "\\mathrm{cal}", "\\mathrm{cal}", "\\mathrm{Btu}", "\\mathrm{eV}", "\\mathrm{J}", "\\mathrm{W}", "\\mathrm{A}", "\\Omega", "\\mathrm{C}", "\\mathrm{V}", "\\mathrm{F}", "\\mathrm{S}", "\\mathrm{Wb}", "\\mathrm{T}", "\\mathrm{H}", "\\mathrm{Gy}", "\\mathrm{Sv}", "\\mathrm{lm}", "\\mathrm{lx}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}"], + stack_unit_other_unit_code:[min, day, amu, u, mmHg, bar, cc, mbar, atm, Torr, rev, deg, rpm, K], + stack_unit_other_unit_conversions:[s*60, 24*60*60*s, amu, amu, 133.322387415*Pa, 10^5*Pa, m^3*10^(-6), 10^2*Pa, 101325*Pa, 101325/760*Pa, 2*pi*rad, pi*rad/180, pi*rad/(30*s), K], + stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{day}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{cc}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{Torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{K}"], +*/ + +/* In Maxima 5.42.2 there are changes to the default simplifier. We can no longer use the default, but need + to add rules and explicitly simplify to deal with stackunits. */ +matchdeclare(STACKNUM1, all, STACKNUM2, all, STACKUNITS1, all, STACKUNITS2, all, STACKANY, all)$ +matchdeclare(STACKNUM, lambda([ex], numberp(ex) and is(ex>0)))$ +tellsimpafter(STACKNUM*stackunits(STACKNUM1,STACKUNITS1), stackunits(STACKNUM*STACKNUM1, STACKUNITS1)); +tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)*stackunits(STACKNUM2, STACKUNITS2), stackunits(STACKNUM1*STACKNUM2, STACKUNITS1*STACKUNITS2)); +tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)*stackunits(STACKNUM2, STACKUNITS2)*STACKANY, stackunits(STACKNUM1*STACKNUM2, STACKUNITS1*STACKUNITS2)*STACKANY); +tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)^STACKNUM, stackunits(STACKNUM1^STACKNUM, STACKUNITS1^STACKNUM)); +tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)+stackunits(STACKNUM2, STACKUNITS1), stackunits(STACKNUM1+STACKNUM2, STACKUNITS1)); +tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)+stackunits(STACKNUM2, STACKUNITS1)+STACKANY, stackunits(STACKNUM1+STACKNUM2, STACKUNITS1)+STACKANY); + + +unitsp(ex) := featurep(ex, 'units)$ + +/* List all variables *not* considered to be not units. */ +listofnonunits(ex) := block( + if not(member('units, features)) then + stack_unit_si_declare(true), + sublist(listofvars(ex), lambda([ex2], not(unitsp(ex2)))) +)$ + +/* List all variables considered to be units. */ +listofunits(ex) := block( + if not(member('units, features)) then + stack_unit_si_declare(true), + sublist(listofvars(ex), unitsp) +)$ + +/* Set \texput rules for SI units. The mode parameter does nothing, */ +/* except skips the syntax validation error... */ +/* We don't apply('declare, [stack_unit_si_unit_code[ui], constant]) as this breaks stackunits_make(ex). */ +stack_unit_si_declare(mode) := block([pfi, ui, simp], + /* Use Maxima's feature system to declare a range of units. */ + /* Whether units is a feature can be used to check if this function has been called. */ + /* Check with member('units, features); */ + declare(units, feature), + simp:true, + for ui:1 thru length(stack_unit_si_unit_code) do + ( + for pfi:1 thru length(stack_unit_si_prefix_code) do + ( + apply('texput, [vconcat(stack_unit_si_prefix_code[pfi],stack_unit_si_unit_code[ui]), sconcat(stack_unit_si_prefix_tex[pfi], stack_unit_si_unit_tex[ui])]), + apply('declare, [vconcat(stack_unit_si_prefix_code[pfi],stack_unit_si_unit_code[ui]), 'units]) + ), + apply('texput, [stack_unit_si_unit_code[ui], stack_unit_si_unit_tex[ui]]), + apply('declare, [stack_unit_si_unit_code[ui], 'units]) + ), + for ui:1 thru length(stack_unit_other_unit_code) do ( + apply('texput, [stack_unit_other_unit_code[ui], stack_unit_other_unit_tex[ui]]), + apply('declare, [stack_unit_other_unit_code[ui], 'units]) + ) +)$ + +/* Converts the whole expression to SI-base units. */ +stack_unit_si_to_si_base(expression) := block([ui, pfi, ex, workex, oldsimp], + oldsimp:simp, + simp:false, + ex:stackunits_make(expression), + /* Remove intert dp/df display functions at this point. */ + ex:ev(ex, displaydp=lambda([a,b],a), displaysf=lambda([a,b],a)), + workex:stack_units_units(ex), + if debug then (print("stack_unit_si_to_si_base: working with the following."), print(ex), print(workex)), + /* If we don't have units there is nothing to do. */ + if is(workex=NULLUNITS) then return(expression), + exop:safe_op(expression), + simp:true, + for ui:1 thru length(stack_unit_other_unit_code) do + ( + workex:subst(stack_unit_other_unit_conversions[ui], stack_unit_other_unit_code[ui], workex) + ), + for ui:1 thru length(stack_unit_si_unit_code) do ( + for pfi:1 thru length(stack_unit_si_prefix_code) do + ( + workex:subst(stack_unit_si_prefix_multiplier[pfi]*stack_unit_si_unit_code[ui], vconcat(stack_unit_si_prefix_code[pfi], stack_unit_si_unit_code[ui]), workex) + ), + workex:subst(stack_unit_si_unit_conversions[ui], stack_unit_si_unit_code[ui], workex) + ), + if debug then (print("stack_unit_si_to_si_base: after base conversion"), print(workex)), + workex:stackunits_make(workex), + if not(stack_units_nums(ex)=NULLNUMS and stack_units_nums(workex)=NULLNUM) then + workex:stackunits(ev(stack_units_nums(ex)*stack_units_nums(workex), NULLNUM=1), stack_units_units(workex)), + /* Return the expression with the operator it started with. */ + simp:oldsimp, + if not(safe_op(expression) = "stackunits") then + workex:stackunits_to_product(workex), + return(workex) +)$ + +stack_unit_si_present(value,target) := block([conversionfactor, va, vb, simp, best, bestc, ii], + simp:true, + bestc:9000000, + if listp(target) then ( + for ii:1 thru length(target) do + ( + va:stack_unit_si_present(value,target[ii]), + if (is(stack_units_nums(va)=0) or is(stack_units_nums(va)=0.0)) + then (best:va,return(best)) + else + ( + vb:abs(log(if is(stack_units_nums(va)=NULLNUM) then 1 else stack_units_nums(va))-sqrt(2)), + if is(vb units. */ + if stack_units_nums(SBU) = NULLNUM then + SBU:stackunits_make(1.0*SB), + SOU:stackunits_make(SO), + + /* If the teacher uses units in the option then they must be identical to the units in the teacher's answer. */ + if (numtest = "Absolute") and not(is_simp(stack_units_units(SOU) = NULLUNITS)) and not(stack_units_units(SBU) = stack_units_units(SOU)) then + (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATUnits_SO_wrong_units"))), + + if (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU), print(SOU)), + + /* The teacher must supply some units, otherwise the test will fail. */ + if is_simp(stack_units_units(SBU) = NULLUNITS) then + (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATUnits_SB_no_units"), StackAddFeedback("", "TEST_FAILED_Q")])), + + /* SA must not be only units. */ + if is_simp(stack_units_nums(SAU) = NULLNUM) then + return([false, false, StackAddNote("", "ATUnits_SA_only_units"), StackAddFeedback("", "ATUnits_SA_only_units")]), + + /* Check if stackunits_make appears to have done something sensible. */ + if not(emptyp(listofvars(stack_units_nums(SAU)))) then + return([false, false, StackAddNote("", "ATUnits_SA_bad_units"), StackAddFeedback("", "ATUnits_SA_bad_units")]), + if is_simp(stack_units_units(SAU) = NULLUNITS) then + return([false, false, StackAddNote("", "ATUnits_SA_no_units"), StackAddFeedback("", "ATUnits_SA_no_units")]), + + /* Strip off units and check the numerical part with ATNumSigFigs. */ + SAU1:ev(float(stack_units_nums(SAU)), simp), + SBU1:ev(float(stack_units_nums(SBU)), simp), + + if (debug) then (print("ATUnitsFun: call to 1st numerical test with data: "), print(SAU1), print(SBU1), print([ol, SOU])), + + if (numtest = "SigFigs") then + /* Sigfigs test should not use units in the option. */ + ret1: ATNumSigFigs(SAU1, SBU1, SO, SR) + else if (numtest = "Relative") then + ret1: ATNumRelative(SAU1, SBU1, SO) + else if (numtest = "Absolute") then + /* Only the absolute test should use units in the option. */ + ret1: ATNumAbsolute(SAU1, SBU1, stack_units_nums(SOU)) + else + ( + print(sconcat("Error: ATUnitsFun received the following numtest option which is unknown: ", numtest)), + ret1:[false] + ), + if (debug) then (print("Result of numerical test: "), print(ret1)), + + /* Did we get an error? If so, then go no further. */ + if not(ret1[1]) then return(ret1), + + /* Check units. If the units match exactly then go no further. + The correctness or otherwise is entirely determined by ATNumSigFigs. */ + if algebraic_equivalence(second(SAU), second(SBU)) then + return([ret1[1], ret1[2], StackAddNote(ret1[3], "ATUnits_units_match"), ret1[4]]), + + /* If the teacher has not used units, then take the teacher's units. */ + if is_simp(stack_units_units(SOU) = NULLUNITS) then ( + SO:stackunits(SO, stack_units_units(SB)), + if (debug) then (print("ATUnits: No units supplied, using the teacher's")) + ), + /* Now convert to base units and compare again. This is for feedback purposes. */ + if (debug) then (print("ATUnits: about to convert the following to base units."), print(SA), print(SB)), + SA:stack_unit_si_to_si_base(SA), + SB:stack_unit_si_to_si_base(SB), + SO:stack_unit_si_to_si_base(SO), + SAU:stackunits_make(SA), + SBU:stackunits_make(SB), + SOU:stackunits_make(SO), + if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU), print(SOU)), + /* Check the accuracy again, now we have converted. */ + SAU1:ev(float(stack_units_nums(SAU)), simp), + SBU1:ev(float(stack_units_nums(SBU)), simp), + SOU1:ev(float(stack_units_nums(SOU)), simp), + if (numtest = "SigFigs") then + ret2: ATNumSigFigs(SAU1, SBU1, ol, SR) + else if (numtest = "Relative") then + ret2: ATNumRelative(SAU1, SBU1, ol) + else if (numtest = "Absolute") then + /* Only the absolute test should use units in the option. */ + ret2: ATNumAbsolute(SAU1, SBU1, SOU1) + else + print(sconcat("Error: ATUnitsFun received the following numtest option which is unknown: ", numtest)), + if (debug) then print(ret2), + + /* Did we get an error? If so, then go no further. */ + if not(ret2[1]) then + return([ret2[1], ret2[2], StackAddNote(ret2[3], "ATUnits_second_numerial_test_failed"), ret2[4]]), + + /* Check for incompatible units. */ + if not(algebraic_equivalence(stack_units_units(SAU), stack_units_units(SBU))) then + ( + if (debug) then print("ATUnits_incompatible_units"), + rawmk:false, + /* What about accuracy? Only look at their actual answer. There is no point + converting the numerical part to base units here as they don't match the teacher's. */ + ansnote:StackAddNote(ret1[3], "ATUnits_incompatible_units"), + if not(strictp) then + fb:StackAddFeedback(ret1[4], "ATUnits_incompatible_units"), + if (ret1[2]) then + ( + ansnote:StackAddNote(ansnote, "ATUnits_correct_numerical"), + if not(strictp) then + fb:StackAddFeedback(fb, "ATUnits_correct_numerical") + ) + ), + if not(algebraic_equivalence(stack_units_units(SAU), stack_units_units(SBU))) then + return([true, false, ansnote, fb]), + + /* We do have compatible units. */ + ansnote:StackAddNote(ret2[3], sconcat("ATUnits_compatible_units ", string(ev(stack_units_units(SBU), simp)))), + fb:ret2[4], + + /* Is the numerical answer correct? */ + if ret2[2] then + if not(strictp) then + return([true, true, ansnote, fb]) + else + return([true, false, ansnote, fb]), + + rawmk:false, + + /* Despite getting the wrong units, was the original numerical value correct? */ + if ret1[2] then + ( + ansnote:StackAddNote("", sconcat("ATUnits_compatible_units ", string(ev(stack_units_units(SBU), simp)))), + ansnote:StackAddNote(ansnote, "ATUnits_correct_numerical"), + fb:StackAddFeedback("", "ATUnits_correct_numerical") + ), + + /* Send back the result. */ + ret:[validity, rawmk, ansnote, fb], + return(ret) + )$ + +/* Legacy function alias for old unit users. */ +backtosibase(expression) := block([simp],return(stack_unit_si_to_si_base(expression)))$ diff --git a/stack/2024060300/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2024060300/maxima/to_poly_solve_extra_5.38.1.lisp new file mode 100644 index 0000000..d4e798f --- /dev/null +++ b/stack/2024060300/maxima/to_poly_solve_extra_5.38.1.lisp @@ -0,0 +1,211 @@ +;; Author Barton Willis +;; University of Nebraska at Kearney +;; Copyright (C) 2008 Barton Willis + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; Removed by CJS. +($load "fourier_elim") + +(defun $simp_inequality (e) + (let ((ee (standardize-inequality e))) + (if (or (eq ee t) (eq ee nil)) ee e))) + +;; non-short-circuited boolean operators and or. + +(mfuncall '$nary "%and") +(defprop %and wxxml-nary wxxml) +(defprop %and" %and " wxxmlsym) +(defprop %and " %and " wxxmlword) +(defprop %and 120. wxxml-lbp) +(defprop %and 120. wxxml-rbp) +(displa-def %and dimension-nary " %and ") +(setf (get '%and 'grind) 'msize-nary) +(defprop %and tex-nary tex) +(defprop %and (" \\land ") texsym) +(setf (get '$%and 'operators) 'simp-%and) +(setf (get '%and 'operators) 'simp-%and) + +;; make op(a %and b) --> "%and" This allows things like if op(e) = "%and" to work. With this disjunction_p and conjuction_p aren't needed. +(putprop '%and "%and" 'op) +(putprop '%or "%or" 'op) + +;; Efficiency hack (see nset.lisp) -- this tells xreduce that %and is nary. +(def-nary '$%and (s) (simplify (cons '(%and) s)) t) + +(defun simp-%and (e yy z) + (declare (ignore yy)) + (let ((not-e) (acc) (b)) + + ;; flatten and simplify each argument + (setq e (margs e)) + (dolist (ek e) + (setq ek (simplifya (specrepcheck ek) z)) + (setq b (standardize-inequality ek)) + (setq ek (if (or (eq b t) (eq b nil)) b ek)) + (if (op-equalp ek '%and) (setq acc (append acc (margs ek))) (push ek acc))) + + ;; setify and remove true + (setq e ($disjoin t (opapply '$set acc))) + + ;; logically negate each member of e + (setq not-e (opapply '$set (mapcar #'(lambda (s) (take '(mnot) s)) (margs e)))) + + ;; simplifications: + ;; (1) if intersect(e, not(e)) # empty, return false, + ;; (2) if false in e, return false, + ;; (3) if e is empty, return true, + ;; (4) if e is a singleton set, return x. + + (cond ((not ($emptyp ($intersection e not-e))) nil) + (($elementp nil e) nil) + (($emptyp e) t) + ((not (cddr e)) (cadr e)) + (t `((%and simp) ,@(margs e)))))) + +(mfuncall '$nary "%or") +(defprop %or wxxml-nary wxxml) +(defprop %or " %or " wxxmlsym) +(defprop %or " %or " wxxmlword) +(defprop %or 120. wxxml-lbp) +(defprop %or 120. wxxml-rbp) + +(defprop %or tex-nary tex) +(defprop %or (" \\lor ") texsym) + +(displa-def %or dimension-nary " %or ") +(setf (get '%or 'grind) 'msize-nary) +(setf (get '$%or 'operators) 'simp-%or) +(setf (get '%or 'operators) 'simp-%or) + +(defun $disjunction_p (e) + (op-equalp e '%or)) + +(defun $conjunction_p (e) + (op-equalp e '%and)) + + +;; Efficiency hack (see nset.lisp) -- this tells xreduce that %or is nary. +(def-nary '$%or (s) (simplify (cons '(%or) s)) nil) + +(defun simp-%or (e yy z) + (declare (ignore yy)) + (let ((not-e) (acc) (b)) + + ;; flatten and simplify each argument + (setq e (margs e)) + (dolist (ek e) + (setq ek (simplifya (specrepcheck ek) z)) + (setq b (standardize-inequality ek)) + (setq ek (if (or (eq b t) (eq b nil)) b ek)) + (if (op-equalp ek '%or) (setq acc (append acc (margs ek))) (push ek acc))) + + ;; setify and remove false + (setq e ($disjoin nil (opapply '$set acc))) + + ;; logically negate each member of e + (setq not-e (opapply '$set (mapcar #'(lambda (s) (take '(mnot) s)) (margs e)))) + + ;; simplifications: + ;; (1) if intersect(e, not(e)) # empty, return true + ;; (2) if true e in e, return true, + ;; (3) if e is empty, return false, + ;; (4) if is a singleton set, return x. + + (cond ((not ($emptyp ($intersection e not-e))) t) + (($elementp t e) t) + (($emptyp e) nil) + ((not (cddr e)) (cadr e)) + (t `((%or simp) ,@(margs e)))))) + +(setf (get '$%union 'operators) 'simp-%union) + +(defun simp-%union (e yy z) + (declare (ignore yy)) + (let ((acc)) + ;; flatten and simplify each argument + (setq e (margs e)) + (dolist (ek e) + (setq ek (simplifya (specrepcheck ek) z)) + (if (op-equalp ek '$%union) (setq acc (append acc (margs ek))) (push ek acc))) + ;; setify and remove $emptyset. + (setq e (margs ($disjoin (take '($set)) (opapply '$set acc)))) + `(($%union simp) ,@e))) + +;; TeX support +(defprop $%union tex-nary tex) +(defprop $%union (" \\cup ") texsym) + +(setf (get '$%if 'operators) 'simp-%if) + +(defun simp-%if (e yy z) + (declare (ignore yy)) + (pop e) ;; remove ($%if simp) + (let (($domain '$complex) + (cnd (if e (simpcheck (pop e) z) (wna-err '$%if))) + (a (if e (pop e) (wna-err '$%if))) + (b (if e (pop e) (wna-err '$%if)))) + (if e (wna-err '$%if)) + (setq cnd (standardize-inequality ($substitute '%or 'mor ($substitute '%and 'mand cnd)))) + (setq cnd ($substitute '%or 'mor ($substitute '%and 'mand cnd))) + (cond ((eq cnd t) (simpcheck a z)) + ((eq cnd nil) (simpcheck b z)) + (t + (setq a (simpcheck a z)) + (setq b (simpcheck b z)) + (if (like a b) a `(($%if simp) ,cnd ,a ,b)))))) + +(setf (get '$%integerp 'operators) 'simp-%integerp) + +(defun simp-%integerp (e yy z) + (declare (ignore yy)) + (oneargcheck e) + (let ((sgn)) + (setq e (simplifya (second e) z)) + (setq sgn ($compare e (take '($floor) e))) + (cond ((equal sgn "=") t) + ((member sgn '("<" ">" "#") :test #'equal) nil) + ((and (symbolp e) ($featurep e '$noninteger)) nil) + (t `(($%integerp simp) ,e))))) + +(setf (get '$isnonnegative_p 'operators) 'simp-isnonnegative-p) + +(defun simp-isnonnegative-p (e yy z) + (declare (ignore yy)) + (oneargcheck e) + (let (($domain '$complex) (is-real) (sgn)) + (setq e (simplifya (specrepcheck (cadr e)) z)) + (setq is-real (take '($isreal_p) e)) + (cond ((eq t is-real) + (setq sgn (csign e)) + (cond ((memq sgn '($zero $pz $pos)) t) + ((eq sgn '$neg) nil) + (t `(($isnonnegative_p simp) ,e)))) + ((eq nil is-real) nil) + (t `(($isnonnegative_p simp) ,e))))) + +;; Similar to sublis, but allow for substitutions of nonatoms. + +(defun $subst_parallel (l e) + (let ((alist nil) (is-a-rat ($ratp e)) (old) (new)) + (setq l (if ($listp l) (margs l) (list l))) + + ;; Build an association list for the Common Lisp sublis function. + (dolist (lk l) + (if (mequalp lk) + (progn + (setq old (cadr lk)) + (setq new (caddr lk)) + (setq old (if (stringp old) (amperchk old) old)) + (push (cons old new) alist)) + (merror "Each substitution must be an equation; found" lk))) + (setq e (resimplify (sublis alist ($ratdisrep e) :test #'alike))) ;;or like? + (if is-a-rat ($rat e) e))) diff --git a/stack/2024060300/maxima/trigrat.lisp b/stack/2024060300/maxima/trigrat.lisp new file mode 100644 index 0000000..868240b --- /dev/null +++ b/stack/2024060300/maxima/trigrat.lisp @@ -0,0 +1,56 @@ +(in-package :maxima) + +(defun $listofei (e ) + (declare (special $d2% $lg% $lexp%)) + (setq $d2% (copy-tree (car e))) + (setq $lg% ()) + (setq $lexp% ()) + (do ((lvar (caddr $d2%) (cdr lvar)) + (lg% (cadddr $d2%) (cdr lg%)) + (var)) + ((null lvar)(setq $lg% (cons '(mlist) $lg%)) + (setq $lexp% (cons '(mlist) $lexp%)) + (setq $d2% (cons $d2% (cdr e))) ) + (setq var (car lvar)) + (cond ((and (mexptp var) + (equal (cadr var) '$%e) +; (mtimesp (caddr var)) +; (eq (cadr (caddr var)) '$%i) + ;; Check that we have a factor of %i. This test includes + ;; cases like %i, and %i*x/2, which we get for e.g. + ;; sin(1) and sin(x/2). + (eq '$%i (cdr (partition (if (atom (caddr var)) + (list '(mtimes)(caddr var)) + (caddr var)) + '$%i 1)))) + (setq $lexp% (cons var $lexp%)) + (setq var (symbolconc "$_" (car lg%))) + (setq $lg% (cons var $lg%)) + (rplaca lvar var))))) + +#$trigrat_equationp (e%) := + not atom (e%) + and member (op (e%), ["=", "#", "<", "<=", ">=", ">"])$ + +#$trigrat(exp):= + if matrixp (exp) or listp (exp) or setp (exp) or trigrat_equationp (exp) + then map (trigrat, exp) + else block([e%,n%,d%,lg%,f%,lexp%,ls,d2%,l2%,alg,gcd1], + alg:algebraic,gcd1:gcd, + algebraic:true,gcd:subres, + e%: rat(ratsimp(expand(exponentialize(exp)))), + n%:num(e%),d%:denom(e%), + listofei(d%), + l2%:map(lambda([u%,v%],u%^((hipow(d2%,v%)+lopow(d2%,v%))/2)), + lexp%,lg%), + f%:if length(lexp%)=0 then 1 + else if length(lexp%)=1 then part(l2%,1) + else apply("*",l2%), + n%:rectform(ratexpand(n%/f%)), + d%:rectform(ratexpand(d%/f%)), + e%:ratsimp(n%/d%,%i), + algebraic:alg,gcd:gcd1, + e%)$ + +; written by D. Lazard, august 1988 +; modified by C. Sangwin, November 2020. \ No newline at end of file diff --git a/stack/2024060300/maxima/unittests_load.mac b/stack/2024060300/maxima/unittests_load.mac new file mode 100644 index 0000000..cba3426 --- /dev/null +++ b/stack/2024060300/maxima/unittests_load.mac @@ -0,0 +1,38 @@ +/* This batch file load unit tests for STACK Maxima */ +/* NOTE: we need to run tests with simp:false and simp:true */ + +/* Currently a lot of these tests report a "fail", but without actually failing. */ +/* The testsuite uses the function approx-alike (defined in src/mload.lisp) to check for equality. */ +/* If we want to fix this we'll need to write your own approx-alike function. */ +/* C:\Program Files\Maxima-5.22.1\share\maxima\5.22.1\src */ + +if featurep(all,constant) then remove(all,constant); +kill(all); + +LOADDIR:"stackmaxima.mac"$ +print("Working from: ")$ +print(LOADDIR)$ +load(LOADDIR)$ +load("stackunits.mac")$ + +no_fails:0$ all_pass:true$ + +simp:true$ +STT:batch("rtest_assessment_simptrue.mac", test); +STB:batch("rtest_assessment_simpboth.mac", test); +STB:batch("rtest_inequalities.mac", test); +STB:batch("rtest_intervals.mac", test); + +simp:false$ +SFF:batch("rtest_assessment_simpfalse.mac", test); +SFB:batch("rtest_assessment_simpboth.mac", test); +STB:batch("rtest_inequalities.mac", test); +STB:batch("rtest_intervals.mac", test); + +print("************ simp is true"); +print(STT); +print(STB); + +print("************ simp is false."); +print(SFF); +print(SFB); diff --git a/stack/2024060300/maxima/utils.mac b/stack/2024060300/maxima/utils.mac new file mode 100644 index 0000000..e471af0 --- /dev/null +++ b/stack/2024060300/maxima/utils.mac @@ -0,0 +1,320 @@ +/* Misc functions for dealing with Maxima and the other tools. */ + +/* Takes a Maxima string and converts everything that could cause trouble in a HTML/XML document to entities. + Note that if the string already contains entities even them are converted and thus broken. */ + +str_to_html_char(c) := if c = "&" then "&" + else if c = "'" then "'" /* ' is for XHTML, we need to still deal with HTML. */ + else if c = "\"" then """ + else if c = ">" then ">" + else if c = "<" then "<" + else c$ +str_to_html(string_to_escape) := simplode(map(str_to_html_char, charlist(string_to_escape)))$ + +/* Same for generating ECMAScript strings. */ +str_to_js_char(c) := if c = "\\" then "\\\\" + else if c = "\"" then "\\\"" + else if c = "'" then "\\'" + else if c = ascii( 8) then "\\b" else if c = ascii( 9) then "\\t" + else if c = ascii(10) then "\\n" else if c = ascii(12) then "\\f" + else if c = ascii(13) then "\\r" else c$ +str_to_js(string_to_escape) := simplode(map(str_to_js_char, charlist(string_to_escape)))$ + +/* Defintion of characters to escape in Markdown. */ +md_escapes(c) := if c = "\\" then "\\\\" + else if c = "*" then "\\*" + else if c = "|" then "|" /* The pipe neds to be converted in case one injects into a table. Mere escaping may not be enough there. */ + else if c = "`" then "`" /* The logic of backtick escaping is not local so we do an entity conversion just in case. */ + else if c = "_" then "\\_" + else if c = "{" then "\\{" + else if c = "}" then "\\}" + else if c = "[" then "\\[" + else if c = "]" then "\\]" + else if c = "(" then "\\(" + else if c = ")" then "\\)" + else if c = "<" then "\\<" + else if c = ">" then "\\>" + else if c = "#" then "\\#" + else if c = "+" then "\\+" + else if c = "-" then "\\-" + else if c = "." then "\\." + else if c = "!" then "\\!" + else c$ + +str_to_md(string_to_escape) := simplode(map(md_escapes,charlist(string_to_escape)))$ + +/* Split a Maxima timestamp (seconds from Jan 1 1900) to numbers representing a date. + The returned list consists of integers [year, month, day, weekday] where Sunday is 7 (ISO 8601). */ +time_to_date(seconds) := block([y,m,d,S], + S: split(first(split(timedate(seconds), " ")), "-"), + y: parse_string(S[1]), + m: parse_string(S[2]), + d: parse_string(S[3]), + return([y, m, d, day_for_date(y, m, d)]) +)$ + +day_for_date(year, month, day) := block([reference, tmp, d], + reference: parse_timedate("1900-01-08 12:00:00"), /* That is a Monday, the 1st was also but time-zones can cause trouble here and we need some space for them. */ + tmp: parse_timedate(sconcat(year, "-", if month < 10 then sconcat("0", month) else month, "-", if day < 10 then sconcat("0", day) else day, " 12:00:00")), + d: floor((tmp - reference)/(24*60*60) + 1/2), /* There are these things called leap seconds let's hope they do not add up to 10 hours to one direction at any point during our lifetimes. */ + while d < 0 do d: d + 7000, /* Considering that Maximas timedate system breaks if given dates from the 19th century this is good enough. */ + d: 1 + mod(d,7), + return(d) +)$ + +/* Generates a continuous list of dates between two dates, the second date is not included in the list but the first is. */ +date_list(yearA, monthA, dayA, yearB, monthB, dayB) := block([y, m, d, wd, S, R, c, et, rev], + rev: false, + if yearA+(monthA/12)+(dayA/366) > yearB+(monthB/12)+(dayB/366) then + rev: true, + if yearA = yearB and monthA = monthB and dayA = dayB then + return([]), + c: parse_timedate(sconcat(yearA, "-", if monthA < 10 then sconcat("0", monthA) else monthA, "-", if dayA < 10 then sconcat("0", dayA) else dayA, " 12:00:00")), + et: parse_timedate(sconcat(yearB, "-", if monthB < 10 then sconcat("0", monthB) else monthB, "-", if dayB < 10 then sconcat("0", dayB) else dayB, " 12:00:00")), + R: [time_to_date(c)], + c: if rev then c - 24*60*60 else c + 24*60*60, + while (c < et and not rev) or (rev and c > et) do ( + S: split(first(split(timedate(c), " ")), "-"), + y: parse_string(S[1]), + m: parse_string(S[2]), + d: parse_string(S[3]), + wd: if not rev then last(last(R)) + 1 else last(last(R)) - 1, + if wd > 7 then wd: 1, + if wd = 0 then wd: 7, + R: append(R, [[y, m, d, wd]]), + c: if rev then c - 24*60*60 else c + 24*60*60 + ), + /* Due to DST and other such fun things that iteration can go over. */ + S: last(R), + if first(S) = yearB and second(S) = monthB and third(S) = dayB then + R: rest(R, -1), + return(R) +)$ + +/* Finds the number of significant digits in the first numeric part of a given string representation of an expression. Pretty much the same logic as the original PHP version stack_utils::decimal_digits. */ +sig_figs_from_str(strexp) := block([leadingzeros,indefinitezeros,trailingzeros,meaningfulldigits,decimalplaces,infrontofdecimaldeparator,scientificnotation,seennumbers,c,i,r,simp], + /* Plenty of countters so needs simp */ + simp: true, + leadingzeros: 0, + indefinitezeros: 0, + trailingzeros: 0, + meaningfulldigits: 0, + decimalplaces: 0, + infrontofdecimaldeparator: true, + scientificnotation: false, + seennumbers: false, + + /* If this is an empty string one probably has trouble. */ + if (slength(strim(" ",strexp)) = 0) then + return(["stack_map", + ["lowerbound", 0], + ["upperbound", 0], + ["decimalplaces", 0], + ["fltfmt", "~a"]]), + + + i: 1, + /* First eat the stuff in front of of the number if it exists */ + while i <= slength(strexp) do ( + c: charat(strexp, i), + + if c = "." then ( + infrontofdecimaldeparator: false, + meaningfulldigits: meaningfulldigits + indefinitezeros, + indefinitezeros: 0, + leadingzeros: 0, + seennumbers: true + ) else if c = "0" then ( + leadingzeros: 1, + seennumbers: true + ) else if member(c,["1","2","3","4","5","6","7","8","9"]) then ( + meaningfulldigits: meaningfulldigits + indefinitezeros + 1, + indefinitezeros: 0, + seennumbers: true + ), + i: i + 1, + + if seennumbers then return(0) + ), + + /* Now we are safely in the number hopefully there is a number... */ + while i <= slength(strexp) do ( + c: charat(strexp, i), + + if infrontofdecimaldeparator = false and member(c,["0","1","2","3","4","5","6","7","8","9"]) then ( + decimalplaces: decimalplaces + 1 + ), + if c = "e" or c = "E" then ( + if (meaningfulldigits + leadingzeros + indefinitezeros) > 0 then ( + scientificnotation: true + ) + ), + + if c = "0" then ( + if meaningfulldigits = 0 then ( + leadingzeros: leadingzeros + 1 + ) else if infrontofdecimaldeparator then ( + indefinitezeros: indefinitezeros + 1 + ) else if meaningfulldigits > 0 then ( + meaningfulldigits: meaningfulldigits + 1 + indefinitezeros + trailingzeros, + trailingzeros: 0, + indefinitezeros: 0 + ) else ( + trailingzeros: trailingzeros + 1 + ) + ) else if c = "." and infrontofdecimaldeparator then ( + infrontofdecimaldeparator: false, + meaningfulldigits: meaningfulldigits + indefinitezeros, + indefinitezeros: 0, + leadingzeros: 0 + ) else if member(c,["1","2","3","4","5","6","7","8","9"]) then ( + meaningfulldigits: meaningfulldigits + indefinitezeros + 1, + indefinitezeros: 0 + ) else ( + if (meaningfulldigits + leadingzeros + indefinitezeros) > 0 then ( + /* Stop only if we have seens something like a number. */ + return(0) + ) + ), + i: i + 1 + ), + + r: ["stack_map", + ["lowerbound", 0], + ["upperbound", 0], + ["decimalplaces", decimalplaces], + ["fltfmt", "~a"]], + + if is(meaningfulldigits = 0) then ( + r: stackmap_set(r, "lowerbound", max(1, leadingzeros)), + r: stackmap_set(r, "upperbound", max(1, leadingzeros)) + ) else if is(infrontofdecimaldeparator=false) then ( + r: stackmap_set(r, "lowerbound", meaningfulldigits), + r: stackmap_set(r, "upperbound", meaningfulldigits) + ) else ( + r: stackmap_set(r, "lowerbound", meaningfulldigits), + r: stackmap_set(r, "upperbound", meaningfulldigits + indefinitezeros) + ), + + if is(decimalplaces > 0) then ( + r: stackmap_set(r, "fltfmt", sconcat("~,", decimalplaces, "f")) + ), + if is(scientificnotation = true) then ( + if is(stackmap_get(r, "lowerbound") > 1) then ( + r: stackmap_set(r, "fltfmt", sconcat("~.", stackmap_get(r, "upperbound"), "e")) + ) else ( + r: stackmap_set(r, "fltfmt", "~e") + ) + ), + return(r) +)$ + + + +FORBIDDEN_SYMBOLS_SET: {"%th", "adapth_depth", "alias", "aliases", "alphabetic", "appendfile", + "apropos", "assume_external_byte_order", "backtrace", "batch", "barsplot", "batchload", + "boxchar", "boxplot", "bug_report", "build_info", "catch", "chdir", "close", "closefile", + "compfile", "compile", "compile_file", "concat", "current_let_rule_package", + "data_file_name", "deactivate", "debugmode", "define", "define_variable", "del_cmd", "demo", + "dependencies", "describe", "dimacs_export", "dimacs_import", "entermatrix", + "error", "error_size", "error_syms", "errormsg", "eval_string", "example", + "feature", "featurep", "features", "file_name", "file_output_append", "file_search", + "file_search_demo", "file_search_lisp", "file_search_maxima", "file_search_tests", + "file_search_usage", "file_type", "filename_merge", "flength", "FORBIDDEN_SYMBOLS_SET", + "fortindent", "fortran", "fortspaces", "fposition", "freshline", "functions", + "fundef", "funmake", "grind", "gnuplot_cmd", "gnuplot_file_name", "gnuplot_out_file", + "gnuplot_preamble", "gnuplot_ps_term_command", "gnuplot_term", "inchar", "infeval", + "infolists", "kill", "killcontext", "labels", "leftjust", "ldisp", "ldisplay", + "lisp", "linechar", "linel", "linenum", "linsolvewarn", "load", "load_pathname", + "loadfile", "loadprint", "macroexpand", "macroexpand1", "macroexpansion", "macros", + "manual_demo", "maxima_tempdir", "maxima_userdir", "mkdir", "multiplot_mode", "myoptions", + "newline", "nolabels", "opena", "opena_binary", "openr", "openr_binary", "openw", + "openw_binary", "outchar", "packagefile", "parse_string", "pathname_directory", + "pathname_name", "pathname_type", "pickapart", "piece", "playback", "plotdf", "print", + "print_graph", "printf", "printfile", "prompt", "psfile", "quit", "read", "read_array", + "read_binary_array", "read_binary_list", "read_binary_matrix", "read_hashed_array", + "read_list", "read_matrix", "read_nested_list", "read_xpm", "readline", "readonly", + "refcheck", "rembox", "remvalue", "remfunction", "reset", "rmxchar", "room", + "run_testsuite", "run_viewer", "save", "savedef", "scatterplot", "starplot", + "stemplot", "set_plot_option", "setup_autoload", "setcheck", "setcheckbreak", + "setval", "showtime", "sparse6_export", "sparse6_import", "splice", "sprint", "status", + "stringout", "supcontext", "system", "tcl_output", "terminal", "tex", "testsuite_files", + "throw", "time", "timer", "timer_devalue", "timer_info", "to_lisp", "trace", "trace_options", + "transcompile", "translate", "translate_file", "transrun", "ttyoff", "untimer", + "untrace", "user_preamble", "values", "with_stdout", "write_binary_data", "write_data", "writefile", + "%_ce_rem" +}$ + +/* This is the allowed version of concat that blocks the possibility to construct certain dangerous things. */ +vconcat([ex]) := block([tmp], + tmp: apply(concat, ex), + if symbolp(tmp) and elementp(sconcat(tmp), FORBIDDEN_SYMBOLS_SET) then + error(sconcat("concat: '", tmp, "' is a forbidden symbol and cannot be constructed.")), + return(tmp) +)$ + +all_ops(%_expr) := block([%_edge, %_next_edge, %_tmp, %_op, %_result], + /* Returns a list of all the operators and functions + in use in the expression. Turn it to a bag if you need + the counts or a set if only the existence matters. */ + %_next_edge : [%_expr], + %_result : [], + while length(%_next_edge) > 0 do ( + %_edge : %_next_edge, + %_next_edge : [], + for %_tmp in %_edge do ( + %_op : safe_op(%_tmp), + if not (%_op = "") then ( + %_result : append(%_result, [%_op]), + %_next_edge : append(%_next_edge, args(%_tmp)) + ) + ) + ), + %_result +)$ + +%_C(%_id) := block([simp], simp:true, + if elementp(sconcat(%_id), FORBIDDEN_SYMBOLS_SET) then ( + error(sconcat("Attempt to call forbidden function detected: ", %_id)) + ) +)$ + +%_E(%_expr) := block([simp,%_tmp], + simp: false, + /* Also forbid these inside this context. */ + %_tmp: intersection(union(FORBIDDEN_SYMBOLS_SET,{"map", "subst", "at", "apply", "fullmap", "fullmapl", "funmake", "maplist", "matrixmap", "outermap", "scanmap", ":", ":="}), setify(all_ops(%_expr))), + if cardinality(%_tmp) > 0 then ( + error(sconcat("Attempt to evaluate a constructed: ", simplode(listify(%_tmp), ", "))) + ), + %_expr +)$ + +/* Remove blocks starting with %_C and %_E from the expression. Only permitted for display functions, e.g. tex1.*/ +%_ce_rem(ex) := block([ex2,simp], + /* We need to assume simp:false, so unevaluated/simplified expressions don't potentially throw errors here. */ + simp:false, + /* The case below is atoms and things like m[k], which should not be processed further. */ + if safe_op(ex) = "" then return(ex), + if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_C" then return(%_ce_rem(second(args(ex)))), + if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_E" then return(%_ce_rem(second(args(ex)))), + /* Rather subtle order of evaluation issue. */ + ex2:args(ex), + ex2:map(%_ce_rem, ex2), + substpart(op(ex), ex2, 0) +)$ +/* We need to compile %_CE_rem so that it is available to lisp as a lisp function. */ +compile(%_ce_rem)$ + +/* Remove %C_ and %E from expessions, but evaluate them now. I.e. expedite the checks. */ +%_ce_expedite(ex) := block([ex2,simp], + /* We need to assume simp:false, so unevaluated/simplified expressions don't potentially throw errors here. */ + simp:false, + /* The case below is atoms and things like m[k], which should not be processed further. */ + if safe_op(ex) = "" then return(ex), + if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_C" then (ev(first(args(ex))), return(%_ce_rem(second(args(ex))))), + if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_E" then (ev(first(args(ex))), return(%_ce_rem(second(args(ex))))), + /* Rather subtle order of evaluation issue. */ + ex2:args(ex), + ex2:map(%_ce_expedite, ex2), + substpart(op(ex), ex2, 0) +)$ diff --git a/stack/2024060300/maxima/validator.mac b/stack/2024060300/maxima/validator.mac new file mode 100644 index 0000000..2205953 --- /dev/null +++ b/stack/2024060300/maxima/validator.mac @@ -0,0 +1,234 @@ +/* Author Chris Sangwin + University of Edinburgh + Copyright (C) 2023 Chris Sangwin + + This program is free software: you can redistribute it or modify + it under the terms of the GNU General Public License version two. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* ******************************************* */ +/* Validate an expression */ +/* ******************************************* */ + +/* List of variables, without some specific tokens in. */ +stack_validate_listofvars(_exunlikelyatom) := block([lvars], + lvars:ev(setify(listofvars(_exunlikelyatom)), simp), + lvars:ev(setdifference(lvars,{null, QMCHAR, EMPTYANSWER}), simp), + lvars:ev(sort(listify(lvars)), simp) +)$ + +stack_validate_checkvars(sexpr, texpr, chkopt) := block([%_sansvar,%_tansvar,%_extras,%_errstr], + if is(chkopt = 0) then return(""), + %_sansvar:setify(stack_validate_listofvars(sexpr)), + %_tansvar:setify(stack_validate_listofvars(texpr)), + %_extras: setdifference(%_sansvar, %_tansvar), + %_missing:setdifference(%_tansvar, %_sansvar), + %_errstr: "", + if ev(length(%_extras) > 0 and mod(chkopt, 2) = 1,simp) then + %_errstr:StackAddFeedback(%_errstr, "ValidateVarsSpurious" , stack_disp_comma_separate(listify(%_extras))), + if ev(length(%_missing) > 0 and (mod(chkopt, 4)-mod(chkopt, 2)) = 2, simp) then + %_errstr:StackAddFeedback(%_errstr, "ValidateVarsMissing" , stack_disp_comma_separate(listify(%_missing))), + /* A non-empty string means invalid. */ + return(%_errstr) +)$ + +stack_validate(expr, LowestTerms, TAns, chkopt) := block([simp:false, exs, SameType, fvs, fvs1, fvs2, chkvars], + /* Try to simply the expression to catch CAS errors */ + exs: errcatch(ev(expr, simp)), + if exs = [] then ( + _APPEND_ERR([errormsgtostring()], "stack_validate"), + return(false) + ), + if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))), + expr: first(expr), + /* Check if the student's answer is the same type as the Teacher's. */ + SameType:ATSameTypefun(expr, TAns), + if ev(is(SameType[2]=false),simp) then print(SameType[4]) + else (_RESET_NOTES(),_RESET_FEEDBACK()), + /* Check variables in the answer. */ + chkvars:stack_validate_checkvars(expr, TAns, chkopt), + if ev(not(is(chkvars="")), simp) then print(chkvars), + /* Check for malformed real sets. */ + if realset_surface_p(expr) then block([ret], + ret:interval_validate_realset(expr), + if not(is(ret="")) then print(ret) + ), + /* Check to see if a variable is also a function name. */ + fvs1: setify(listofvars(expr)), + fvs2: get_ops(expr), + fvs: ev(intersection(fvs1, fvs2), simp), + if ev(not(is(fvs={})), simp) then + print(StackAddFeedback("", "Variable_function", stack_disp(fvs, "i"))), + /* Checks fractions are in lowest terms. */ + if LowestTerms and all_lowest_termsex(expr)=false then + print(StackAddFeedback("", "Lowest_Terms")), + /* Check for x=1 or 2. */ + exs:stack_validate_missing_assignment(expr), + if first(exs) then + print(StackAddFeedback("", "Bad_assignment", stack_disp(second(exs), "i"))), + /* Now display the result. */ + simp: false, + expr: detexcolor(expr), + return(expr) +)$ + +/* Validate an expression without type checking. Floats and mathematical errors only. */ +stack_validate_typeless(expr, LowestTerms, TAns, chkopt, Equiv) := block([simp:false, exs, fvs, fvs1, fvs2], + /* Try to simply the expression to catch CAS errors */ + exs: errcatch(ev(expr, simp)), + if exs = [] then ( + _APPEND_ERR([errormsgtostring()], "stack_validate_typeless"), + return(false) + ), + if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))), + expr: first(expr), + /* Check variables in the answer. */ + chkvars:stack_validate_checkvars(expr, TAns, chkopt), + if ev(not(is(chkvars="")), simp) then print(chkvars), + /* Check for malformed real sets. */ + if realset_surface_p(expr) then block([ret], + ret:interval_validate_realset(expr), + if not(is(ret="")) then print(ret) + ), + /* Check to see if a variable is also a function name. */ + fvs1: setify(listofvars(expr)), + fvs2: get_ops(expr), + fvs: ev(intersection(fvs1, fvs2), simp), + if ev(not(is(fvs={})), simp) then + print(StackAddFeedback("", "Variable_function", stack_disp(fvs, "i"))), + /* Check for floats, and if there are any then throw an error */ + /* Checks fractions are in lowest terms */ + if LowestTerms and all_lowest_termsex(expr) = false then + print(StackAddFeedback("", "Lowest_Terms")), + /* Check for x=1 or 2. */ + exs: stack_validate_missing_assignment(expr), + if first(exs) then + print(StackAddFeedback("", "Bad_assignment", stack_disp(second(exs), "i"))), + /* Additional tests which restrict the equivalence input type. */ + if Equiv and op_usedp(expr, set) then print(StackAddFeedback("", "Equiv_Illegal_set")), + if Equiv and op_usedp(expr, "{") then print(StackAddFeedback("", "Equiv_Illegal_set")), + if Equiv and op_usedp(expr, "[") then print(StackAddFeedback("", "Equiv_Illegal_list")), + if Equiv and op_usedp(expr, matrix) then print(StackAddFeedback("", "Equiv_Illegal_matrix")), + /* Now display the result. */ + simp: false, + return(expr) +)$ + +/* This function replaces all variables starting with a % sign with elements from var */ +stack_strip_percent(ex,var) := block([lv1, lv2, subcount, indx,exs], + subcount:0, + lv2:[], + lv1:listofvars(ex), + if [] = lv then return(ex), + for indx:1 thru length(lv1) do ( + if cequal(charat(string(lv1[indx]), 1),"%") then block( + subcount:subcount+1, + lv2:append(lv2, [lv1[indx] = var[subcount]]) + ) + ), + if not(emptyp(lv2)) then exs:subst(lv2, ex) else exs:ex, + return(exs) +)$ + +/* Create a list of numbered variables. */ +stack_var_makelist(ex, n1) := block( + if not(atom(ex)) then error("stack_var_makelist: first argument must be an atom"), + if not(integerp(n1)) or not(ev(is(n1>=0), simp)) then error("stack_var_makelist: second argument must be a non-negative integer"), + return(ev(makelist(vconcat(ex,k), k, 0, n1), simp)) +)$ + +/* Spot the very specific pattern x=1 nounor 2 instead of x=1 nounor x=2. */ +/* Returns a list: [pattern found, changed expression]. */ +stack_validate_missing_assignment(ex) := block([ret, ex2, v, exop], + if not(safe_op(ex)="nounor" or safe_op(ex)="nounand") + then return([false, ex]), + if length(listofvars(ex))#1 + then return([false, ex]), + ex2: args(ex), + exop: op(ex), + /* Do we have any equations which look like assignments? */ + if not(any_listp(lambda([ex], equationp(ex) and atom(lhs(ex)) and not(simp_numberp(lhs(ex)))),ex2)) + then return([false, ex]), + /* Do any of them look bad, that just a number on its own? */ + if all_listp(lambda([ex], not(is(listofvars(ex)=[]))), ex2) + then return([false, ex]), + v: first(listofvars(ex)), + ex: maplist(lambda([ex], if (equationp(ex) and atom(lhs(ex)) and not(simp_numberp(lhs(ex)))) then ex else v=ex), ex2), + ex: apply(exop, ex), + return([true, ex]) +)$ + +/* ****************************************** */ +/* Functions associated with validators */ +/* ****************************************** */ + +/** + * A convenience function for combining validators, to be used with the input validator system. + * Executes all functions received and produces a combined output. + * + * @param[expression] the input value to be validated. + * @param[list of identifers] the names of the functions to be combined. + * @return[string or CASText] the result of those validations. + */ +stack_multi_validator(ex, validators):=block([%_tmp, %_val, %_errfound], + %_tmp:[], + %_errfound:false, + for %_val in validators do block([%_tested], + /* Since we evluate all functions we have no opportunity for guard clauses. + Hence, we expect some errors, and therefore don't use EC. + Instead errors are trapped at this level, not the session level. + */ + %_tested:errcatch(%_val(ex)), + if emptyp(%_tested) then + %_errfound:true + else + %_tmp:append(%_tmp,%_tested) + ), + /* Add the error message only once. */ + /* See https://github.com/maths/moodle-qtype_stack/issues/870 on how to generate this from a castext() call. */ + if %_errfound then %_tmp:append(%_tmp, [ ["%root",["%cs","inputvalidatorerrcouldnot"]] ]), + /* Remove all valid results.*/ + %_tmp: delete("", delete(true, %_tmp)), + if %_tmp = [] then return(""), + /* Then concatenate CASText2 segments. Add spaces between multiple failures. */ + /* `rest` currently requires that simp, for negative arguments. */ + %_tmp:ev(lreduce(castext_concat, rest(join(%_tmp, makelist(" ", length(%_tmp))), -1)), simp) +); + +/** + * A convenience function for combining validators, to be used with the input validator system. + * Executes functions received until one fails, and returns the first output as fail. + * Any errors thrown should be considered authoring errors. + * + * @param[expression] the input value to be validated. + * @param[list of identifers] the names of the functions to be combined. + * @return[string or CASText] the result of those validations. + */ +stack_seq_validator(ex, validators):=block([%_tmp, %_val, %_continue], + %_tmp:"", + %_continue:true, + /* Use a loop instead of while to simplify test fail logic. */ + for %_val in validators do block( + if %_continue then block( + /* Don't use _EC or errcatch as only one test should fail. Any error is a genuine authoring error. */ + %_tmp:%_val(ex), + if is(%_tmp=true) or is(%_tmp="") then ( + %_continue:true + ) else ( + %_continue:false + ) + ) + ), + %_tmp +); + +/* ****************************************** */ +/* Supported validators */ +/* ****************************************** */ diff --git a/stack/2024060300/maximalocal.mac.template b/stack/2024060300/maximalocal.mac.template new file mode 100644 index 0000000..3b777fc --- /dev/null +++ b/stack/2024060300/maximalocal.mac.template @@ -0,0 +1,41 @@ +/* ***********************************************************************/ +/* This file is automatically generated at installation time. */ +/* The purpose is to transfer configuration settings to Maxima. */ +/* Hence, you should not edit this file. Edit your configuration. */ +/* This file is regularly overwritten, so your changes will be lost. */ +/* ***********************************************************************/ + +/* File generated on June 3, 2024, 4:58 pm */ + +/* Add the location to Maxima's search path */ +file_search_maxima:append( [sconcat("${LIB}/###.{mac,mc}")] , file_search_maxima)$ +file_search_lisp:append( [sconcat("${LIB}/###.{lisp}")] , file_search_lisp)$ +file_search_maxima:append( [sconcat("${LOG}/###.{mac,mc}")] , file_search_maxima)$ +file_search_lisp:append( [sconcat("${LOG}/###.{lisp}")] , file_search_lisp)$ + +STACK_SETUP(ex):=block( + MAXIMA_VERSION_NUM_EXPECTED:44, + MAXIMA_PLATFORM:"server", + maxima_tempdir:"${TMP}", + IMAGE_DIR:"${PLOT}", + PLOT_SIZE:[450,300], + PLOT_TERMINAL:"svg", + PLOT_TERM_OPT:"dynamic font \",11\" linewidth 1.2", + DEL_CMD:"rm", + GNUPLOT_CMD:"gnuplot", + MAXIMA_VERSION_EXPECTED:"5.44.0", + URL_BASE:"!ploturl!", + /* Define units available in STACK. */ + stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y], + stack_unit_si_prefix_multiplier:[10^-24, 10^-21, 10^-18, 10^-15, 10^-12, 10^-9, 10^-6, 10^-3, 10^-2, 10^-1, 10, 10^2, 10^3, 10^6, 10^9, 10^12, 10^15, 10^18, 10^21, 10^24], + stack_unit_si_prefix_tex:["\\mathrm{y}", "\\mathrm{z}", "\\mathrm{a}", "\\mathrm{f}", "\\mathrm{p}", "\\mathrm{n}", "\\mu ", "\\mathrm{m}", "\\mathrm{c}", "\\mathrm{d}", "\\mathrm{da}", "\\mathrm{h}", "\\mathrm{k}", "\\mathrm{M}", "\\mathrm{G}", "\\mathrm{T}", "\\mathrm{P}", "\\mathrm{E}", "\\mathrm{Z}", "\\mathrm{Y}"], + stack_unit_si_unit_code:[m, l, L, g, t, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, Wh, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, lx, lm, mol, M, kat, rad, sr, K, VA, eV, Ci], + stack_unit_si_unit_conversions:[m, m^3/1000, m^3/1000, kg/1000, 1000*kg, s, s*3600, 1/s, 1/s, cd, (kg*m)/s^2, kg/(m*s^2), 4.2*J, 4200*J, 1055*J, 1.602177e-19*J, (kg*m^2)/s^2, (kg*m^2)/s^3, 3600*(kg*m^2)/s^2, A, (kg*m^2)/(s^3*A^2), s*A, (kg*m^2)/(s^3*A), (s^4*A^2)/(kg*m^2), (s^3*A^2)/(kg*m^2), (kg*m^2)/(s^2*A), kg/(s^2*A), (kg*m^2)/(s^2*A^2), m^2/s^2, 0.01*Sv, m^2/s^2, cd/m^2, cd, mol, mol/(m^3/1000), mol/s, rad, sr, K, VA, 1.602176634E-19*J, Ci], + stack_unit_si_unit_tex:["\\mathrm{m}", "\\mathrm{l}", "\\mathrm{L}", "\\mathrm{g}", "\\mathrm{t}", "\\mathrm{s}", "\\mathrm{h}", "\\mathrm{Hz}", "\\mathrm{Bq}", "\\mathrm{cd}", "\\mathrm{N}", "\\mathrm{Pa}", "\\mathrm{cal}", "\\mathrm{cal}", "\\mathrm{Btu}", "\\mathrm{eV}", "\\mathrm{J}", "\\mathrm{W}", "\\mathrm{Wh}", "\\mathrm{A}", "\\Omega", "\\mathrm{C}", "\\mathrm{V}", "\\mathrm{F}", "\\mathrm{S}", "\\mathrm{Wb}", "\\mathrm{T}", "\\mathrm{H}", "\\mathrm{Gy}", "\\mathrm{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{lm}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}", "\\mathrm{sr}", "\\mathrm{K}", "\\mathrm{VA}", "\\mathrm{eV}", "\\mathrm{Ci}"], + stack_unit_other_unit_code:[min, amu, u, mmHg, bar, ha, cc, gal, mbar, atm, torr, rev, deg, rpm, au, Da, Np, B, dB, day, year, hp, in, ft, yd, mi, lb], + stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 10^4*m^2, m^3*10^(-6), 3.785*l, 10^2*Pa, 101325*Pa, 101325/760*Pa, 2*pi*rad, pi*rad/180, pi*rad/(30*s), 149597870700*m, 1.660539040E-27*kg, Np, B, dB, 86400*s, 3.156e7*s, 746*W, in, 12*in, 36*in, 5280*12*in, 4.4482*N], + stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{ha}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{au}", "\\mathrm{Da}", "\\mathrm{Np}", "\\mathrm{B}", "\\mathrm{dB}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{hp}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{yd}", "\\mathrm{mi}", "\\mathrm{lb}"], + true)$ +/* Load the main libraries. */ +/* load("stackmaxima.mac")$ */ +print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$ diff --git a/versions b/versions index 2a9ccb2..d977f9f 100644 --- a/versions +++ b/versions @@ -21,3 +21,4 @@ 2023102700 5.44.0 2.2.6 2023121100 5.44.0 2.2.6 2024012900 5.44.0 2.2.6 +2024060300 5.44.0 2.2.6