From ec3c7c4fd06cd4a43e2288bdf783f1efc5d09f3c Mon Sep 17 00:00:00 2001
From: Lennart Kramer <lennart.kramer@stud.uni-goettingen.de>
Date: Wed, 8 Jul 2020 17:18:11 +0200
Subject: [PATCH] Add new stack versions
---
stack/2020052700/maxima/assessment.mac | 2359 ++++++++++++
stack/2020052700/maxima/assessment.texi | 568 +++
stack/2020052700/maxima/casanswertest.mac | 254 ++
stack/2020052700/maxima/elementary.mac | 521 +++
stack/2020052700/maxima/errortostring.lisp | 8 +
stack/2020052700/maxima/expandfeedback.mac | 139 +
stack/2020052700/maxima/experimental.mac | 167 +
stack/2020052700/maxima/inequalities.mac | 306 ++
stack/2020052700/maxima/intervals.mac | 929 +++++
stack/2020052700/maxima/noun_arith.lisp | 53 +
.../maxima/rtest_assessment_simpboth.mac | 373 ++
.../maxima/rtest_assessment_simpfalse.mac | 125 +
.../maxima/rtest_assessment_simptrue.mac | 86 +
stack/2020052700/maxima/rtest_elementary.mac | 179 +
.../2020052700/maxima/rtest_experimental.mac | 0
.../2020052700/maxima/rtest_inequalities.mac | 238 ++
stack/2020052700/maxima/rtest_intervals.mac | 161 +
stack/2020052700/maxima/sandbox.wxm | 85 +
stack/2020052700/maxima/stack_logic.lisp | 678 ++++
stack/2020052700/maxima/stackmaxima.mac | 3185 +++++++++++++++++
stack/2020052700/maxima/stackreporting.mac | 27 +
stack/2020052700/maxima/stackstrings.mac | 296 ++
stack/2020052700/maxima/stacktex.lisp | 444 +++
stack/2020052700/maxima/stacktex40.lisp | 121 +
stack/2020052700/maxima/stackunits.mac | 598 ++++
.../maxima/to_poly_solve_extra_5.38.1.lisp | 211 ++
stack/2020052700/maxima/unittests_load.mac | 38 +
stack/2020052700/maxima/utils.mac | 229 ++
stack/2020061000/maxima/assessment.mac | 2359 ++++++++++++
stack/2020061000/maxima/assessment.texi | 568 +++
stack/2020061000/maxima/casanswertest.mac | 254 ++
stack/2020061000/maxima/elementary.mac | 521 +++
stack/2020061000/maxima/errortostring.lisp | 8 +
stack/2020061000/maxima/expandfeedback.mac | 139 +
stack/2020061000/maxima/experimental.mac | 167 +
stack/2020061000/maxima/inequalities.mac | 306 ++
stack/2020061000/maxima/intervals.mac | 929 +++++
stack/2020061000/maxima/noun_arith.lisp | 53 +
.../maxima/rtest_assessment_simpboth.mac | 373 ++
.../maxima/rtest_assessment_simpfalse.mac | 125 +
.../maxima/rtest_assessment_simptrue.mac | 86 +
stack/2020061000/maxima/rtest_elementary.mac | 179 +
.../2020061000/maxima/rtest_experimental.mac | 0
.../2020061000/maxima/rtest_inequalities.mac | 238 ++
stack/2020061000/maxima/rtest_intervals.mac | 161 +
stack/2020061000/maxima/sandbox.wxm | 85 +
stack/2020061000/maxima/stack_logic.lisp | 678 ++++
stack/2020061000/maxima/stackmaxima.mac | 3185 +++++++++++++++++
stack/2020061000/maxima/stackreporting.mac | 27 +
stack/2020061000/maxima/stackstrings.mac | 296 ++
stack/2020061000/maxima/stacktex.lisp | 444 +++
stack/2020061000/maxima/stacktex40.lisp | 121 +
stack/2020061000/maxima/stackunits.mac | 598 ++++
.../maxima/to_poly_solve_extra_5.38.1.lisp | 211 ++
stack/2020061000/maxima/unittests_load.mac | 38 +
stack/2020061000/maxima/utils.mac | 229 ++
stack/2020070100/maxima/acos.lisp | 57 +
stack/2020070100/maxima/arccos.lisp | 54 +
stack/2020070100/maxima/assessment.mac | 2359 ++++++++++++
stack/2020070100/maxima/assessment.texi | 568 +++
stack/2020070100/maxima/casanswertest.mac | 254 ++
stack/2020070100/maxima/cos-1.lisp | 56 +
stack/2020070100/maxima/elementary.mac | 521 +++
stack/2020070100/maxima/errortostring.lisp | 8 +
stack/2020070100/maxima/expandfeedback.mac | 139 +
stack/2020070100/maxima/experimental.mac | 167 +
stack/2020070100/maxima/inequalities.mac | 306 ++
stack/2020070100/maxima/intervals.mac | 929 +++++
stack/2020070100/maxima/noun_arith.lisp | 53 +
.../maxima/rtest_assessment_simpboth.mac | 373 ++
.../maxima/rtest_assessment_simpfalse.mac | 125 +
.../maxima/rtest_assessment_simptrue.mac | 86 +
stack/2020070100/maxima/rtest_elementary.mac | 179 +
.../2020070100/maxima/rtest_experimental.mac | 0
.../2020070100/maxima/rtest_inequalities.mac | 238 ++
stack/2020070100/maxima/rtest_intervals.mac | 161 +
stack/2020070100/maxima/sandbox.wxm | 85 +
stack/2020070100/maxima/stack_logic.lisp | 678 ++++
stack/2020070100/maxima/stackmaxima.mac | 3146 ++++++++++++++++
stack/2020070100/maxima/stackreporting.mac | 27 +
stack/2020070100/maxima/stackstrings.mac | 296 ++
stack/2020070100/maxima/stacktex.lisp | 451 +++
stack/2020070100/maxima/stacktex40.lisp | 121 +
stack/2020070100/maxima/stackunits.mac | 602 ++++
.../maxima/to_poly_solve_extra_5.38.1.lisp | 211 ++
stack/2020070100/maxima/unittests_load.mac | 38 +
stack/2020070100/maxima/utils.mac | 229 ++
versions | 3 +
88 files changed, 37276 insertions(+)
create mode 100644 stack/2020052700/maxima/assessment.mac
create mode 100644 stack/2020052700/maxima/assessment.texi
create mode 100644 stack/2020052700/maxima/casanswertest.mac
create mode 100644 stack/2020052700/maxima/elementary.mac
create mode 100644 stack/2020052700/maxima/errortostring.lisp
create mode 100644 stack/2020052700/maxima/expandfeedback.mac
create mode 100644 stack/2020052700/maxima/experimental.mac
create mode 100644 stack/2020052700/maxima/inequalities.mac
create mode 100644 stack/2020052700/maxima/intervals.mac
create mode 100644 stack/2020052700/maxima/noun_arith.lisp
create mode 100644 stack/2020052700/maxima/rtest_assessment_simpboth.mac
create mode 100644 stack/2020052700/maxima/rtest_assessment_simpfalse.mac
create mode 100644 stack/2020052700/maxima/rtest_assessment_simptrue.mac
create mode 100644 stack/2020052700/maxima/rtest_elementary.mac
create mode 100644 stack/2020052700/maxima/rtest_experimental.mac
create mode 100644 stack/2020052700/maxima/rtest_inequalities.mac
create mode 100644 stack/2020052700/maxima/rtest_intervals.mac
create mode 100644 stack/2020052700/maxima/sandbox.wxm
create mode 100644 stack/2020052700/maxima/stack_logic.lisp
create mode 100644 stack/2020052700/maxima/stackmaxima.mac
create mode 100644 stack/2020052700/maxima/stackreporting.mac
create mode 100644 stack/2020052700/maxima/stackstrings.mac
create mode 100644 stack/2020052700/maxima/stacktex.lisp
create mode 100644 stack/2020052700/maxima/stacktex40.lisp
create mode 100644 stack/2020052700/maxima/stackunits.mac
create mode 100644 stack/2020052700/maxima/to_poly_solve_extra_5.38.1.lisp
create mode 100644 stack/2020052700/maxima/unittests_load.mac
create mode 100644 stack/2020052700/maxima/utils.mac
create mode 100644 stack/2020061000/maxima/assessment.mac
create mode 100644 stack/2020061000/maxima/assessment.texi
create mode 100644 stack/2020061000/maxima/casanswertest.mac
create mode 100644 stack/2020061000/maxima/elementary.mac
create mode 100644 stack/2020061000/maxima/errortostring.lisp
create mode 100644 stack/2020061000/maxima/expandfeedback.mac
create mode 100644 stack/2020061000/maxima/experimental.mac
create mode 100644 stack/2020061000/maxima/inequalities.mac
create mode 100644 stack/2020061000/maxima/intervals.mac
create mode 100644 stack/2020061000/maxima/noun_arith.lisp
create mode 100644 stack/2020061000/maxima/rtest_assessment_simpboth.mac
create mode 100644 stack/2020061000/maxima/rtest_assessment_simpfalse.mac
create mode 100644 stack/2020061000/maxima/rtest_assessment_simptrue.mac
create mode 100644 stack/2020061000/maxima/rtest_elementary.mac
create mode 100644 stack/2020061000/maxima/rtest_experimental.mac
create mode 100644 stack/2020061000/maxima/rtest_inequalities.mac
create mode 100644 stack/2020061000/maxima/rtest_intervals.mac
create mode 100644 stack/2020061000/maxima/sandbox.wxm
create mode 100644 stack/2020061000/maxima/stack_logic.lisp
create mode 100644 stack/2020061000/maxima/stackmaxima.mac
create mode 100644 stack/2020061000/maxima/stackreporting.mac
create mode 100644 stack/2020061000/maxima/stackstrings.mac
create mode 100644 stack/2020061000/maxima/stacktex.lisp
create mode 100644 stack/2020061000/maxima/stacktex40.lisp
create mode 100644 stack/2020061000/maxima/stackunits.mac
create mode 100644 stack/2020061000/maxima/to_poly_solve_extra_5.38.1.lisp
create mode 100644 stack/2020061000/maxima/unittests_load.mac
create mode 100644 stack/2020061000/maxima/utils.mac
create mode 100644 stack/2020070100/maxima/acos.lisp
create mode 100644 stack/2020070100/maxima/arccos.lisp
create mode 100644 stack/2020070100/maxima/assessment.mac
create mode 100644 stack/2020070100/maxima/assessment.texi
create mode 100644 stack/2020070100/maxima/casanswertest.mac
create mode 100644 stack/2020070100/maxima/cos-1.lisp
create mode 100644 stack/2020070100/maxima/elementary.mac
create mode 100644 stack/2020070100/maxima/errortostring.lisp
create mode 100644 stack/2020070100/maxima/expandfeedback.mac
create mode 100644 stack/2020070100/maxima/experimental.mac
create mode 100644 stack/2020070100/maxima/inequalities.mac
create mode 100644 stack/2020070100/maxima/intervals.mac
create mode 100644 stack/2020070100/maxima/noun_arith.lisp
create mode 100644 stack/2020070100/maxima/rtest_assessment_simpboth.mac
create mode 100644 stack/2020070100/maxima/rtest_assessment_simpfalse.mac
create mode 100644 stack/2020070100/maxima/rtest_assessment_simptrue.mac
create mode 100644 stack/2020070100/maxima/rtest_elementary.mac
create mode 100644 stack/2020070100/maxima/rtest_experimental.mac
create mode 100644 stack/2020070100/maxima/rtest_inequalities.mac
create mode 100644 stack/2020070100/maxima/rtest_intervals.mac
create mode 100644 stack/2020070100/maxima/sandbox.wxm
create mode 100644 stack/2020070100/maxima/stack_logic.lisp
create mode 100644 stack/2020070100/maxima/stackmaxima.mac
create mode 100644 stack/2020070100/maxima/stackreporting.mac
create mode 100644 stack/2020070100/maxima/stackstrings.mac
create mode 100644 stack/2020070100/maxima/stacktex.lisp
create mode 100644 stack/2020070100/maxima/stacktex40.lisp
create mode 100644 stack/2020070100/maxima/stackunits.mac
create mode 100644 stack/2020070100/maxima/to_poly_solve_extra_5.38.1.lisp
create mode 100644 stack/2020070100/maxima/unittests_load.mac
create mode 100644 stack/2020070100/maxima/utils.mac
diff --git a/stack/2020052700/maxima/assessment.mac b/stack/2020052700/maxima/assessment.mac
new file mode 100644
index 0000000..63cc178
--- /dev/null
+++ b/stack/2020052700/maxima/assessment.mac
@@ -0,0 +1,2359 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/****************************************************************/
+/* An assessment package for Maxima */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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 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)
+)$
+
+/* 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. */
+count_occurances(ex, v):=block(
+ if ex=v then return(1),
+ if atom(ex) then return(0),
+ apply("+", map(lambda([ex2], count_occurances(ex2, v)), 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 ret:apply("and", maplist(p, l)) else ret:"fail"$
+
+/* any_listp(p,l) true if all elements of l satisfy p. */
+any_listp(p, l) := if listp(l) then ret:apply("or", maplist(p, l)) else ret:"fail"$
+
+/* 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)))$
+
+/* 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!
+*/
+exdowncase(ex) := block([lv],
+ lv:listofvars(ex),
+ lv:map(lambda([v], v=parse_string(sdowncase(string(v)))),lv),
+ return(subst(lv,ex)))$
+
+/* 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")$
+
+
+/* ********************************** */
+/* Type predicates */
+/* ********************************** */
+
+/* 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)
+)$
+
+/* 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_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)="/" 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,
+ ex:errcatch(ev(fullratsimp(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)
+)$
+
+/* 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
+ 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)
+)$
+
+/* 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)) 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,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)))
+)$
+
+
+/* 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],
+ [n, dp]:args(ex),
+ ss:sconcat("~,", string(dp), "f"),
+ if is(equal(dp,0)) then ss:"~d",
+ ev(printf(false, ss, ev(float(n))), simp)
+);
+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(make_displaydpvalue, args(ex)))),
+ return(first(args(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) := 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],
+ [n, dp, expo]:args(ex),
+ ss:sconcat("~,", string(dp), "f \\times 10^{~a}"),
+ if is(equal(dp, 0)) then ss:"~d \\times 10^{~a}",
+ ev(printf(false, ss, ev(float(n)), expo), simp)
+)$
+texput(displaysci, displayscitex)$
+
+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)))
+)$
+
+/* ********************************** */
+/* 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, ex, vi],
+ /* 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,
+ /* 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. */
+ SA:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SA),
+ SB:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SB),
+ if not(freeof(displaydp, SA)) then
+ SA:remove_displaydp(SA),
+ if not(freeof(displaydp, SB)) then
+ SA:remove_displaydp(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),
+ 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),
+ 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, stack_mtell_quiet],
+ stack_mtell_quiet:true,
+ /* 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. */
+ pvars:listofvars([p1,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(ev(p1-p2, lv, simp)),
+ if debug then print(lv, pval),
+ /* 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. (p1)"), return(false)),
+ pval:errcatch(ev(is(abs(first(pval)) > 1/10000), simp)),
+ if is(pval = []) then (print("STACK: ignore previous error. (p1)"), 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))),
+ /* Now we evaluate the difference of the expressions at each variable. */
+ p1:errcatch(ev(float(p1), lv, numer_pbranch:true, simp)),
+ if is(p1 = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ p2:errcatch(ev(float(p2), lv, numer_pbranch:true, simp)),
+ if is(p2 = []) then (print("STACK: ignore previous error. (p2)"), 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)),
+ /* print([p1,p2,sz]), */
+ if is(sz = []) then (print("STACK: ignore previous error."), return(false)),
+ if first(sz) > 0.0001 then true else 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(ex1,ex2):=block([lv1, lv2, lvi, lvp, lvs, lve, il, perm_size, simp],
+ 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:listify(setdifference(lv1, get_ops(ex1))),
+ lv2:listify(setdifference(lv2, get_ops(ex2))),
+ if length(lv1)#length(lv2) then return([]),
+ /* 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 (
+ lv1:setify(lv1),
+ lv2:setify(lv2),
+ lvi:intersection(lv1, lv2),
+ lv1:listify(setdifference(lv1, lvi)),
+ lv2:listify(setdifference(lv2, lvi))
+ ),
+ if length(lv1)>perm_size then return(false),
+ /* */
+ lvp:listify(permutations(lv2)),
+ /* Create a list of subsitutions */
+ lvs:map(lambda([ex], zip_with("=", lv1, ex)), lvp),
+ /* 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)))
+)$
+
+/* ********************************** */
+/* Noun arithmetic */
+/* ********************************** */
+
+/* ** Noun forms of the arithmetic functions ** */
+
+/* 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.
+*/
+
+/* Create noun forms of the functions of +, -, *, / and ^
+ as follows.
+ + noun+
+ - noun-
+ * noun*
+ / noun/
+ ^ noun^
+*/
+
+/* 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("noun=", 150);
+nary("noun+", 100);
+prefix("noun-", 100);
+nary("noun*", 120);
+infix("noun/", 122, 123);
+infix("noun^", 140, 139);
+prefix("UNARY_RECIP", 100);
+
+declare("noun*", commutative);
+declare("noun+", commutative);
+
+/* (2) */
+load("noun_arith.lisp");
+
+/* (3) */
+declare("noun=", commutative);
+declare("noun=", lassociative);
+declare("noun=", rassociative);
+
+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
+)$
+
+verb_arith(ex) := block([a],
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:subst("/", "noun/", ex),
+ ex:subst("^", "noun^", ex),
+ define(UNARY_RECIP a, a^(-1)),
+ ex:ev(ex, UNARY_MINUS=-1),
+ remfunction("noun+", "noun*", "noun/", "noun^", "noun-", "UNARY_RECIP"),
+ ex
+)$
+
+/* (4) */
+noun_arith(ex) := block([a],
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex),
+ /* Unary minus really communtes with multiplication. */
+ ex:subst(lambda([ex], UNARY_MINUS noun* ex), "-", ex),
+ /* Turn 1/x into x^(-1), in a special form */
+ ex:subst(lambda([ex1, ex2], ex1 noun* (UNARY_RECIP ex2)), "/", ex),
+ define(UNARY_RECIP a, a noun^ (-1)),
+ ex:ev(subst("noun^", "^", ex)),
+ remfunction("UNARY_RECIP"),
+ ev(ex)
+)$
+
+/* (5) Assumes we are working in the context of noun operators. */
+gather_reduce(ex) := block(
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:ev(flatten(ex), simp),
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex), --
+ ex:subst("noun-", "-", 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)="noun+" or op(ex)="noun*" 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)="noun=" or safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="nounnot" or safe_op(ex)="nounset" or op(ex)="noun+" or op(ex)="noun*" 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)="noun^") then return(ex),
+ if not(second(args(ex))=-1) then return(ex),
+ if safe_op(first(args(ex)))="noun^" and integerp(second(args(first(args(ex))))) then return("noun^"(first(args(first(args(ex)))),-second(args(first(args(ex)))))),
+ ex
+);
+
+/* Recursive rule which takes UNARY_MINUS noun* n, where n is an integer to -n */
+unary_minus_remove(ex):= block(
+ if atom(ex) then return(ex),
+ if safe_op(ex)="noun*" and is(first(args(ex))=UNARY_MINUS) and integerp(second(args(ex))) then return(-second(args(ex))),
+ apply(op(ex), maplist(unary_minus_remove, args(ex)))
+);
+
+/* (7) */
+/* 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:subst(nounset,set,ex1),
+ ex2n:subst(nounset,set,ex2),
+ ex1n:noun_arith(ex1n),
+ ex2n:noun_arith(ex2n),
+ ex1n:flatten_recurse_nouns(ex1n),
+ ex2n:flatten_recurse_nouns(ex2n),
+ ex1n:sort_nouns(ex1n),
+ ex2n:sort_nouns(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"), ""]),
+
+ sa:remove_stackeq(sa),
+ sb:remove_stackeq(sb),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(sa,sb),
+ 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(sa, sb)),
+ 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(sa, sb) 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)$
+
+/****************************************************************/
+/* Define noun versions of logical "and" and "or". */
+/****************************************************************/
+
+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 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(integrate), 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);
+
+/* 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 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)
+)$
+
+/****************************/
+/* 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\\mbox{(?)}}");
+/* Here we add tags. These are for localisation. Dealt with on the PHP side in cassession -> instantiate. */
+texput(SAMEROOTS, "\\color{green}{\\mbox{!SAMEROOTS!}}");
+texput(ANDOR, "\\color{red}{\\mbox{!ANDOR!}}");
+texput(MISSINGVAR, "\\color{red}{\\mbox{!MISSINGVAR!}}");
+texput(ASSUMEPOSVARS, "\\color{blue}{\\mbox{!ASSUMEPOSVARS!}}");
+texput(ASSUMEREALVARS, "\\color{blue}{(\\mathbb{R})}");
+texput(ASSUMEPOSREALVARS, "\\color{blue}{\\mbox{!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("\\mbox{!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_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 ", FAA, " and ", FAB),
+ 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(
+ ATres:ev(ATAlgEquiv(SA, first(FBB)), simp),
+ if (debug) then print(ATres),
+ if second(ATres) then block(
+ 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(single_variable_solver_real(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.*/
+ note: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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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/2020052700/maxima/assessment.texi b/stack/2020052700/maxima/assessment.texi
new file mode 100644
index 0000000..8e3b16f
--- /dev/null
+++ b/stack/2020052700/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} noun+ (@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} noun* (@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} noun^ (@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} noun- (@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 noun* 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 noun* ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 noun* (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<x,x<4])
+ (%i3) to_poly_solve(abs(x)<2,x);
+ (%o3) %union([-2<x,x<2])
+ @end example
+ These need to be incorporated, expanded and developed.
+@item A test which finds a mapping of variable names which makes two expressions equal (or returns ``false''). Also known as unification.
+@item Tests which deal with scientific units.
+@item Step-by-step derivation of standard types of problems.
+@item A larger range of buggy rules.
+@end enumerate
+
+@bye
+
+@chapter References
+
+@itemize @asis
+
+@mybibitem{Sangwin2010IGI}
+M. Badger and C.J. Sangwin. My equations are the same as yours!: computer aided assessment using a Grobner basis approach.
+In A. A. Juan, M. A. Huertas, and C. Steegmann, editors, Teaching Mathematics Online: Emergent Technologies and Methodologies. IGI Global, 2011.
+
+@end itemize
+
+@bye
+
+@mybibitem{Sangwin2009CalculumusII}
+R. Bradford, J. H. Davenport, and C. J. Sangwin. A comparison of equality in computer algebra and correctness in mathematical pedagogy. The International Journal for Technology in Mathematics Education, 2010.
+
+@mybibitem{Caviness1970}
+B. F. Caviness. On canonical forms and simplification. Journal of the ACM (JACM), 17(2):385-396, 1970.
+
+@mybibitem{CervalPena2008}
+E. R. Cerval-Pena. Automated computer-aided formative assessment with ordinary differential equations. Master's thesis, University of Birmingham, 2008.
+
+@mybibitem{Fenichel1966}
+R. R. Fenichel. An On-line System for Algebraic Manipulation. Phd thesis, Harvard Graduate School of Arts and Sciences, 1966.
+
+@mybibitem{Harjula2008}
+M. Harjula. Mathematics exercise system with automatic assessment. Master's thesis, Helsinki University of Technology, 2008.
+
+@mybibitem{Jenks1992}
+R. D. Jenks and R. S. Sutor. AXIOM: the scientific computation system. The Numerical Algorithms Group Ltd, 1992. ISBN: 0-387-07855-0.
+
+@mybibitem{Lowe2010}
+T. Lowe. e-Assessment using Symbolic Manipulation Tools. Technical report, Centre for Open Learning of Mathematics, Science, Computing and Technology, The Open University, 2010.
+
+@mybibitem{Moses1971}
+J. Moses. Algebraic simplification a guide for the perplexed. Communications of the ACM, 14(8):527-537, August 1971.
+
+@mybibitem{Nakamura2010}
+Y. Nakamura. The STACK e-Learning and Assessment System for mathematics, science and engineering education through Moodle, chapter Preface, pages vi-vii.
+Tokyo Denki University Press, 2010. In Japanese. ISBN 978-4-501-54820-9.
+
+@mybibitem{Rasila2007}
+A. Rasila, M. Harjula, and K. Zenger.
+Automatic assessment of mathematics exercises: Experiences and future prospects.
+In ReflekTori 2007: Symposium of Engineering Education, pages 70-80. Helsinki University of Technology, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2007.
+
+@mybibitem{Rasila2010}
+A. Rasila, L. Havola, Majander H., and J. Malinen. Automatic assessment in engineering mathematics: evaluation of the impact.
+In ReflekTori 2010: Symposium of Engineering Education. Aalto University, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2010.
+
+@mybibitem{Richardson1966}
+D. Richardson. Solvable and Unsolable Problems Involving Elementary Functions of a Real Variable. PhD thesis, University of Bristol, 1966.
+
+@mybibitem{Ruokokoski2009}
+J. Ruokokoski. Automatic assessment in university-level mathematics. Master's thesis, Helsinki University of Technology, 2009.
+
+@mybibitem{SangwinTMA03}
+C. J. Sangwin. Assessing mathematics automatically using computer algebra and the internet. Teaching Mathematics and its Applications, 23(1):1-14, 2004.
+
+@mybibitem{Sangwin2006CASAlgebra}
+C. J. Sangwin. Assessing Elementary Algebra with STACK.
+International Journal of Mathematical Education in Science and Technology, 38(8):987-1002, December 2008.
+
+@mybibitem{2010STACKReport}
+C. J. Sangwin. Who uses STACK? A report on the use of the STACK CAA system. Technical report, The Maths Stats and OR Network, School of Mathematics, The University of Birmingham, 2010.
+
+@mybibitem{WebALT2006}
+C. J. Sangwin and M. J. Grove.
+STACK: addressing the needs of the ``neglected learners''. In Proceedings of the First WebALT Conference and Exhibition January 5-6, Technical University of Eindhoven, Netherlands, pages 81-95. Oy WebALT Inc, University of Helsinki, ISBN 952-99666-0-1, 2006.
+
+@mybibitem{Sleeman1982}
+D. Sleeman and J. S. Brown, editors. Intelligent Tutoring Systems. Academic Press, 1982.
+
+@mybibitem{Wild2009}
+I. Wild. Moodle 1.9 Math. Packt Publishing, 2009.
+
+@end itemize
+
+@bye
+
+
+@node Function and variable index, , Definitions for MYTOPIC, Top
+@appendix Function and variable index
+@printindex fn
+@printindex vr
+
+@bye
+
+@C \documentclass[11pt]{article}
+@C \newcommand{\href}[2]{#2}
+@C \begin{document}
+@C \bibliographystyle{plain}
+@C
+@C \cite{Jenks1992,Richardson1966,Caviness1970,Moses1971}\cite{Fenichel1966,Sleeman1982}\cite{Sangwin2010IGI,Sangwin2009CalculumusII}\cite{Sangwin2006CASAlgebra, WebALT2006,SangwinTMA03} \cite{CervalPena2008,Wild2009,Lowe2010,2010STACKReport}\cite{Rasila2007,Rasila2010,Ruokokoski2009,Harjula2008,Nakamura2010}.
+@C
+@C \bibliography{/Bib/education,/Bib/sangwin,/Bib/PUS,/Bib/MathsTexts,/Bib/CAA,/Bib/sr,/Bib/students}
+@C
+@C \end{document}
+
+@c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+@deffn {Function} expressionp (@var{ex})
+@end deffn
\ No newline at end of file
diff --git a/stack/2020052700/maxima/casanswertest.mac b/stack/2020052700/maxima/casanswertest.mac
new file mode 100644
index 0000000..b28d0f6
--- /dev/null
+++ b/stack/2020052700/maxima/casanswertest.mac
@@ -0,0 +1,254 @@
+/* This file contains functions used to wrap previously PHP side portions of
+ answertest processing over the existing CAS side logic to allow those tests
+ to be executed fully on CAS side. Some of this logic relies on the raw string
+ values of student inputs being available. */
+
+
+/* These are essentially the old atnumsigfigs.class.php with some validation happening outside this. */
+ATNumSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans) := block([allowextra,requiredsigfigs,requiredaccuracy,digits,result,Validity,RawMark,FeedBack,AnswerNote],
+ /* The return value */
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* First unpack the options. */
+ /* Note, in this test we first define the required number of significant digits,
+ no more no less, we may also define a second parameter that provides three
+ ways of function.
+
+ First for positive values, it defines the number of those significant digits
+ that need to match the correct ones. Makes no sense for this to be bigger than
+ the number of required digits.
+
+ Second for zero value it means that we do not care about the value only of the
+ form i.e. you can input any digits you want as long as they can be interpreted
+ as the correct number of significant digits.
+
+ Third for the special value of -1 it defines that we allow more significant
+ digits than what we require and that the value must match for those we require.
+ */
+ requiredsigfigs: 3,
+ requiredaccuracy: -1,
+ allowextra: false,
+
+ if listp(options) then (
+ requiredsigfigs: options[1],
+ requiredaccuracy: options[2]
+ ) else (
+ requiredsigfigs: options,
+ requiredaccuracy: options
+ ),
+
+ if ev(is(requiredaccuracy = -1),simp) then (
+ allowextra: true,
+ requiredaccuracy: requiredsigfigs
+ ),
+
+ /* What if the options do not make sense? */
+ /* Note that the options may now be dynamic and evaluated in CAS. */
+ if requiredsigfigs <= 0 or requiredaccuracy < 0 or not integerp(requiredsigfigs) or not integerp(requiredaccuracy) then (
+ return([false, false, "STACKERROR_OPTION.", ""])
+ ),
+
+ /* Find the number of digits. */
+ digits: sig_figs_from_str(rawsans),
+
+ if allowextra = true then (
+ if requiredsigfigs > 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 (
+ result: ATNumSigFigs(sans,tans,requiredaccuracy),
+ Validity: Validity and result[1],
+ RawMark: RawMark and result[2],
+ if result[3] # "" then (
+ AnswerNote: sconcat(AnswerNote, result[3])
+ ),
+ if result[4] # "" then (
+ FeedBack: sconcat(FeedBack, result[4])
+ )
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+
+ATSigFigsStrict_CASSigFigsWrapper(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])
+)$
+
+ATUnitsSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans,strict) := block([tmp1, tmp2],
+ /* First the units and value */
+ tmp1: ATUnitsFun(sans, tans, options, strict, "SigFigs"),
+
+ /* If we do not have valid stuff for units tests we better drop out now. */
+ if is(tmp1[1] = false) then return(tmp1),
+
+ /* Then check the figures */
+ tmp2: ATNumSigFigs_CASSigFigsWrapper(
+ float(stack_units_nums(stack_unit_si_to_si_base(sans))),
+ float(stack_units_nums(stack_unit_si_to_si_base(tans))),options,rawsans),
+
+ /* Merge*/
+ return([tmp1[1] and tmp2[1], tmp1[2] and tmp2[2], sconcat(tmp1[3],tmp2[3]), sconcat(tmp1[4],tmp2[4])])
+)$
+
+ATNumDecPlaces_CASDecPlacesWrapper(sans,tans,options,rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote,required,val],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ RawMark: false,
+ Validity: false
+ ),
+
+ if Validity then (
+ /* 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])
+)$
+
+
+ATDecimalPlacesWrong(sans,tans,options) := block([Validity,RawMark,FeedBack,AnswerNote,_sans,_tans,required],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_displaydp(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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ 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_displaydp(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/2020052700/maxima/elementary.mac b/stack/2020052700/maxima/elementary.mac
new file mode 100644
index 0000000..4a97fa2
--- /dev/null
+++ b/stack/2020052700/maxima/elementary.mac
@@ -0,0 +1,521 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+
+/* 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 */
+
+/* http://www.ncl.ac.uk/math/numbas/manual.pdf and
+https://github.com/numbas/Numbas/blob/master/runtime/scripts/jme-display.js#L749
+
+ unitDenominator transform x/1 to x
+ zeroPower transform x^0 to 1
+ simplifyFractions transform (a*b)/(a*c) to b/c
+ zeroBase transform 0^x to 0
+ sqrtProduct simplify sqrt(a)*sqrt(b) to sqrt(a*b)
+ sqrtDivision simplify sqrt(a)/sqrt(b) to sqrt(a/b)
+ sqrtSquare simplify sqrt(x^2) to x
+ trig simplify various trigonometric values e.g. sin(n*pi) to 0
+ otherNumbers simplify 2^3 to 8
+ fractionNumbers display all numbers as fractions instead of decimals
+*/
+
+/* NOTE: all these operations really need three separate
+things, as with zeroAdd:
+
+zeroAddp - the predicate which matches to the pattern zeroAdd -
+perform the rule on the top level. zeroAddr - recurse over the
+whole expression applying the rule.
+
+What about working through to the first occurance of the
+pattern?
+
+What about identifying the first occurance of where a rule is
+satisfied?
+
+*/
+
+/*******************************************/
+/* Control functions */
+/*******************************************/
+
+/* List of all available rules */
+ID_TRANS:["zeroAdd","zeroMul","oneMul","onePow","idPow","zeroPow","zPow"]$
+ALG_TRANS:["assAdd","assMul","unaryAdd","unaryMul","comAdd","comMul"]$
+NEG_TRANS:["negZero","negDef","negNeg","negInt","negMinusOne","negDistAdd","negProdA","negProdB"]$
+INT_ARITH:["intAdd","intMul","intPow"]$
+DIV_TRANS:["oneDiv","idDiv","divDivA","divDivB","recipDef","recipNeg","recipMul"]$
+DIS_TRANS:["disAddMul"]$
+POW_TRANS:["powLaw"]$
+ALL_TRANS:append(ALG_TRANS,ID_TRANS,INT_ARITH,NEG_TRANS,DIV_TRANS,DIS_TRANS,POW_TRANS)$
+
+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)))$
+
+
+/* Transform recursively accross an expression*/
+transr(ex,rl):=block(
+ if atom(ex) then return(ex),
+ if listp(rl) then error("transr: only apply one rule using transr"),
+ if trans_topp(ex,rl) then
+ /* If applying the rule changes the expression then do so */
+ block([ex2], ex2:apply(parse_string(rl),[ex]), if ex=ex2 then ex else transr(ex2,rl) )
+ else return(map(lambda([ex2],transr(ex2,rl)),ex))
+)$
+
+/* Apply a list of rules recursively, in order, once each */
+transl(ex,rll):=block(
+ if atom(ex) or not(listp(rll)) or emptyp(rll) then return(ex),
+ return(transl(transr(ex,first(rll)),rest(rll)))
+)$
+
+/*******************************************/
+/* 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)))
+)$
+
+
+/*******************************************/
+/* Transformation rules */
+/*******************************************/
+
+/* 0+x -> x */ /* Strictly zero at the first part */
+zeroAddp(ex):= block(
+ if safe_op(ex)="+" and is(part(ex,1)=0) then true else false
+)$
+
+zeroAdd(ex) := block(
+ if zeroAddp(ex) then
+ return( block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("+",rest(args(ex)))))),
+ return(ex)
+)$
+
+/* zeroMul transform 0*x to 0 */
+zeroMulp(ex) := block(
+ if safe_op(ex)="*" and is(part(ex,1)=0) then true else false
+)$
+
+zeroMul(ex) := block(
+ if zeroMulp(ex) then return(0) else return (ex)
+)$
+
+/* oneMul transform 1*x to x */
+oneMulp(ex) := block([ex2],
+ if safe_op(ex)="*" and is(part(ex,1)=1) then true else false
+)$
+
+oneMul(ex) := block([ex2],
+ if oneMulp(ex) then
+ return(block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("*",rest(args(ex))))))
+ else return(ex)
+)$
+
+/* 1^x -> 1 */
+onePowp(ex):=block(
+ if safe_op(ex)="^" and is(part(ex,1)=1) then true else false
+)$
+
+onePow(ex):= if onePowp(ex) then 1 else ex$
+
+/* x^1 -> x */
+idPowp(ex):=block(
+ if safe_op(ex)="^" 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 safe_op(ex)#"^" 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 safe_op(ex)#"^" 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$
+
+/* "+"(x) -> x. (Probably not needed, but we may end up with sums of lists of length 1.)*/
+unaryAddp(ex):= block(
+ if safe_op(ex)="+" and length(args(ex))=1 then true else false
+)$
+
+unaryAdd(ex):= if unaryAddp(ex) then first(args(ex)) else ex$
+
+/* "*"(x) -> x. (Probably not needed.)*/
+unaryMulp(ex):= block(
+ if safe_op(ex)="*" and length(args(ex))=1 then true else false
+)$
+
+unaryMul(ex):= if unaryMulp(ex) then first(args(ex)) 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)="+" and flatten(ex)#ex then true else false$
+assAdd(ex) := if assAddp(ex) then flatten(ex) else ex$
+
+assMulp(ex):= if safe_op(ex)="*" and flatten(ex)#ex then true else false$
+assMul(ex) := if assMulp(ex) then flatten(ex) else ex$
+
+/* Define a predicate to sort elements, NEG at the front, RECIP at the end. */
+orderelementaryp(exa,exb):=block(
+ if exa=NEG then return(true),
+ if exb=NEG then return(false),
+ if safe_op(exa)="RECIP" and safe_op(exb)="RECIP" then return(orderlessp(part(exa,1),part(exb,1))),
+ if safe_op(exa)="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)#"RECIP")),
+ l2:sublist(l, lambda([ex],not(atom(ex)) and safe_op(ex)="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)="+" and apply("+",elsort(args(ex)))#ex then true else false$
+comAdd(ex) := if comAddp(ex) then apply("+",elsort(args(ex))) else ex$
+
+comMulp(ex):= if safe_op(ex)="*" and apply("*",elsort(args(ex)))#ex then true else false$
+comMul(ex) := if comMulp(ex) then apply("*",elsort(args(ex))) else ex$
+
+/*******************************************/
+/* Double negation -(-(a)) */
+negNegp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if safe_op(part(ex,1))="-" then return(true) else return(false)
+)$
+
+negNeg(ex):=if negNegp(ex) then part(ex,1,1) else ex$
+
+/* -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))
+)$
+
+/* Negation of zero -0 -> 0 */
+negZerop(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if is(part(ex,1)=0) then return(true) else return(false)
+)$
+
+negZero(ex):=if negZerop(ex) then 0 else ex$
+
+/* Turns the negation of an integer into an actual integer "-"(n) -> -n */
+negIntp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if integerp(part(ex,1)) then return(true) else return(false)
+)$
+
+negInt(ex):=if negIntp(ex) then ev(ex,simp) else ex$
+
+/* Turns unary minus in a product into a special symbol NEG */
+negProdAp(ex):=block(
+ if safe_op(ex)#"*" then return(false),
+ return(any_listp(lambda([ex],if safe_op(ex)="-" then true else false),args(ex)))
+)$
+
+negProdA(ex):=block(
+ if negProdAp(ex)=false then return(ex),
+ apply("*",maplist(lambda([ex],if safe_op(ex)="-" then NEG*first(args(ex)) else ex),args(ex)))
+)$
+
+/* matches up to NEG*... and turns this back into unary minus... */
+negProdBp(ex):=if safe_op(ex)="*" and first(args(ex))=NEG then true else false$
+
+negProdB(ex):=block(
+ if negProdBp(ex)=false then return(ex),
+ -apply("*",rest(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)
+)$
+
+
+/* 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)))
+)$
+
+/* 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)
+)$
+
+/* 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
+)$
+
+/*******************************************/
+/* Warning, this is not safe on non-atoms, it evaluates them! */
+notintegerp(ex):= if atom(ex) then not(integerp(ex)) else true$
+
+/* Evaluate integer arithmetic */
+intAddp(ex):=block(
+ if safe_op(ex)#"+" then return(false),
+ if length(sublist(args(ex), integerp))>1 then return(true) else return(false)
+)$
+
+intAdd(ex):=block([a1,a2],
+ if intAddp(ex)=false then return(ex),
+ a1:sublist(args(ex), integerp),
+ a1:ev(apply("+",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1+first(a2)
+ else a1+apply("+",a2)
+)$
+
+intMulp(ex):=block(
+ if safe_op(ex)#"*" 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), integerp),
+ a1:ev(apply("*",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1*first(a2)
+ else apply("*",append([a1],a2))
+)$
+
+intPowp(ex):=block(
+ if safe_op(ex)#"^" 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)
+)$
+
+/*******************************************/
+/* Division rules */
+
+/* a/1 -> a */
+oneDivp(ex):= if safe_op(ex)="/" and part(ex,2)=1 then true else false$
+oneDiv(ex) := if oneDivp(ex) then part(ex,1) else ex$
+
+/* 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$
+
+/* a/(b/c)-> a*(c/b) */
+divDivAp(ex) := if safe_op(ex)="/" and safe_op(part(ex,2))="/" then true else false$
+divDivA(ex) := if divDivAp(ex) then part(ex,1)*(part(ex,2,2)/part(ex,2,1)) else ex$
+
+/* (a/b)/c-> a/(c*b) */
+divDivBp(ex) := if safe_op(ex)="/" and safe_op(part(ex,1))="/" then true else false$
+divDivB(ex) := if divDivBp(ex) then part(ex,1,1)/(part(ex,1,2)*part(ex,2)) else ex$
+
+/*******************************************/
+/* RECIP */
+
+/* re-write a/b as RECIP */
+
+recipDefp(ex) := if safe_op(ex)="/" then true else false$
+recipDef(ex) := if recipDefp(ex) then part(ex,1)*RECIP(part(ex,2))$
+
+/* RECIP(-x) -> -RECIP(x) */
+recipNegp(ex) := if safe_op(ex)="RECIP" and safe_op(part(ex,1))="-" then true else false$
+recipNeg(ex) := if recipNegp(ex) then -RECIP(part(ex,1,1)) else ex$
+
+/* a*RECP(b)*RECIP(c) -> a*RECIP(b*c) */
+recipMulp(ex) := block([l],
+ if safe_op(ex)#"*" then return(false),
+ if length(args(ex))=1 then return(false),
+ l:reverse(args(ex)),
+ if safe_op(first(l))="RECIP" and safe_op(second(l))="RECIP" then true else false
+)$
+
+recipMul(ex) := block([p1,p2],
+ if recipMulp(ex)#true then return(ex),
+ l:reverse(args(ex)),
+ apply("*",append(reverse(rest(rest(l))),[RECIP(part(second(l),1)*part(first(l),1))]))
+)$
+
+/*******************************************/
+/* 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)
+);
+
+/*******************************************/
+/* Buggy rules */
+
+/* (a+b)^n -> a^n+b^n */
+buggyPowp(ex):=block(
+ if safe_op(ex)#"^" then return(false),
+ if safe_op(part(ex,1))="+" then true else false
+)$
+
+buggyPow(ex):= if buggyPowp(ex) then apply("+",map(lambda([ex2],ex2^part(ex,2)),args(part(ex,1)))) else ex$
+
+/* -(a+b) -> -a+b */
+buggyNegDistAddp(ex) := negDistAddp(ex)$
+buggyNegDistAdd(ex) := if buggyNegDistAddp(ex) then apply("+",append([-first(args(part(ex,1)))],rest(args(part((ex),1))))) else ex$
+
+
+/*******************************************/
+/* Testing */
+simp:false;
+/*STT:batch("rtest_elementary.mac", test);*/
+simp:false;
+
+
+
diff --git a/stack/2020052700/maxima/errortostring.lisp b/stack/2020052700/maxima/errortostring.lisp
new file mode 100644
index 0000000..df6ba14
--- /dev/null
+++ b/stack/2020052700/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/2020052700/maxima/expandfeedback.mac b/stack/2020052700/maxima/expandfeedback.mac
new file mode 100644
index 0000000..8d688ae
--- /dev/null
+++ b/stack/2020052700/maxima/expandfeedback.mac
@@ -0,0 +1,139 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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)$
+
+
+/* This function applies the binary function f to two lists a and b
+ returning a list [ f(a[1],b[1]), f(a[2],b[2]), ... ]
+ zip_with quietly gives up when one of the list runs out of elements. */
+zip_with(f,a,b) := block(
+ if listp(a)= false then return(false),
+ if listp(b)= false then return(false),
+ if a = [] then return([]),
+ if b = [] then return([]),
+ cons(f(first(a),first(b)),zip_with(f,rest(a),rest(b)))
+)$
+
+/* 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/2020052700/maxima/experimental.mac b/stack/2020052700/maxima/experimental.mac
new file mode 100644
index 0000000..3ee1f9e
--- /dev/null
+++ b/stack/2020052700/maxima/experimental.mac
@@ -0,0 +1,167 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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))));
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 January 2013 */
+/* */
+/****************************************************************/
+
+/* Sample ways of representing a PRT in which we might have errors */
+
+/* Evaluate a single node safely. */
+node_no(prt,num,inputs) := block([res,err],
+ /* Type checking */
+ if not(listp(prt)) then error("node_no expects its first argument to be a list."),
+ if not(integerp(num)) then error("node_no expects its second argument to be an integer."),
+ if is(length(prt)<num) then error("node_no expects its second argument to less than the length of the first."),
+ /* Do computation */
+ res:errcatch(ev(prt[num],inputs,nouns)),
+ if is([] = res) then
+ print(concat("Previous error generated by node number ", string(num), ".")),
+ if is([] = res) then
+ []
+ else
+ first(res)
+ );
+
+/* Actually traverse the PRT with given inputs */
+/* Inputs should be in the form of equations such as [ans1=x^2] */
+traverse_prt(inputs) := block(
+ /* Type checking */
+ if not(listp(inputs)) then error("traverse_prt expects its argument to be a list."),
+ if not(alllistp(equationp,inputs)) then error("traverse_prt expects its argument to be a list of equations."),
+ /* Setup PRT */
+ simp:false,
+ PRTtests:[
+ 'ATAlgEquiv(ans1,x^3),
+ 'ATInt(ans2,[x^3,x]),
+ 'ATInt(ans2/0,[x^3,x])
+ ],
+ quiet:[false,false,false],
+ nexttrue:[2,3,1],
+ nextfalse:[1,1,1],
+ /* Creatlist to store previously visited nodes */
+ visited:makelist(false, length(PRTtests)),
+ current_node:1,
+ feedback:[],
+ answernote:[],
+ /* Actually traverse the tree */
+ while not(visited[current_node]) do block([res],
+ visited[current_node]:true,
+ res:node_no(PRTtests,current_node,inputs),
+ if not(listp(res)) then return(false),
+ /* Feedback */
+ if not(quiet[current_node]) then feedback:cons(res[4], feedback),
+ feedback:cons(concat("[STACK-feedback:",string(current_node),"-",string(res[2]),"]"), feedback),
+ /* Answernotes */
+ if not(is(res[3] = "")) then answernote:cons(res[3], answernote),
+ answernote:cons(concat(string(current_node),"-",string(res[2])), answernote),
+ /* Update to next node */
+ if res[2] then
+ current_node:nexttrue[current_node]
+ else
+ current_node:nextfalse[current_node]
+ ),
+ answernote:simplode(reverse(sublist(answernote, lambda([ex],not(is(ex=""))))), " | " ),
+ feedback:simplode(reverse(sublist(feedback, lambda([ex],not(is(ex=""))))), " | " ),
+ [answernote, feedback]
+)$
+
+print("[ STACK-reports started. ]")$
+
+/****************************************************************/
+/* Unary minus functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 March 2014 */
+/* */
+/****************************************************************/
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_minus_simp(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and first(args(ex))<0 then return(ev(ex,simp)),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "-" then return(first(args(first(args(ex))))),
+ apply(op(ex), map(unary_minus_minus_simp, args(ex)) )
+)$
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_add_distrib(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "+" then return(apply("+", map(lambda([ex2],-ex2), args(first(args(ex)))))),
+ apply(op(ex), map(unary_minus_add_distrib, args(ex)) )
+)$
+
+/****************************************************************/
+/* Square root functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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/2020052700/maxima/inequalities.mac b/stack/2020052700/maxima/inequalities.mac
new file mode 100644
index 0000000..4455ae9
--- /dev/null
+++ b/stack/2020052700/maxima/inequalities.mac
@@ -0,0 +1,306 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* 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, <chris@sangwin.com> */
+/* 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],
+ 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. */
+ ev(expand(ex/abs(numerical_coeff(ex))), simp)
+)$
+
+/* 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<x or x<a: a syntactic transformation. */
+inequality_disp(ex) := block([ex2, v],
+ if not(linear_inequalityp(ex)) then return(ex),
+ ex2:ineqprepare(ex),
+ v:first(listofvars(ex2)),
+ if equal(coeff(lhs(ex2), v), 1) then return(rev_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ if equal(coeff(lhs(ex2), v), -1) then return(neg_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ return(ex)
+)$
+
+/* Reverses the inequality: purely syntactic. */
+rev_ineq(ex):=block(
+ 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)),
+ 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)<lhs(ex)),
+ if op(ex)=">=" then return(rhs(ex)<=lhs(ex)),
+ return(apply(op(ex), map(make_less_ineq, args(ex))))
+)$
+
+/* Used to checks if we have the wrong inequality. */
+neg_ineq(ex):=block(
+ 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)
+)$
+
+/* 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<?, x<=?. */
+ exg:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = 1))),
+ exl:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = -1))),
+ /* Separate into solution and operator. */
+ exg:single_linear_ineq_reduce_h(exg, first(exo), true),
+ exl:single_linear_ineq_reduce_h(exl, second(exo), false),
+ append(exg, exl)
+)$
+
+/* Take a list of linear inequalities of the same sign, in a single variable, and an operator, min/max.
+ Return the single equivalent inequality.
+*/
+single_linear_ineq_reduce_h(exl, exo, odr):=block([m1,m2,m3,exg],
+ if exl=[] then return([]),
+ if not(is(exo = max) or is(exo = min)) then error("single_linear_ineq_reduce_h expects second argument to be max or min."),
+ exg:maplist(lambda([ex2],[rhs(first(solve(lhs(ex2)))), op(ex2)]), exl),
+ m1:apply(exo, maplist(first,exg)),
+ m2:sublist(exg,lambda([ex2],is(m1=first(ex2)))),
+ /* Get list of operators. Used to sort out >, >= 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)),
+ /* 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),
+ 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/2020052700/maxima/intervals.mac b/stack/2020052700/maxima/intervals.mac
new file mode 100644
index 0000000..55ed26f
--- /dev/null
+++ b/stack/2020052700/maxima/intervals.mac
@@ -0,0 +1,929 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* A package for manipulating intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* Re-written, May 2020. Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* 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 then Ans:{}, /* Our interval is the empty set if y<x. */
+ if x=y then Ans:{x}, /* Simply the set {x} is x=y. */
+ Ans
+)$
+
+oo_num(x,y) := block([Ans],
+ Ans: 'oo(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf ), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y) and not(y=inf or y=-inf ), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+co_num(x,y) := block([Ans],
+ Ans: 'co(x,y),
+ if ev(not real_numberp(x), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev((not real_numberp(y) and not(y=inf or y=-inf)), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+oc_num(x,y) := block([Ans],
+ Ans: 'oc(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+/* Validate student's input. */
+
+/* Return a list of errors for a single connected component. */
+interval_validate_single_interval(ex) := block([ret, iop, il, ir],
+ ret:"",
+ if trivialintervalp(ex) then return(""),
+ if not(intervalp(ex)) then
+ return(StackAddFeedback("", "Interval_notinterval", stack_disp(ex, "i"))),
+ if not(is(length(args(ex))=2)) then
+ /* The tex functions only cope with two arguments, so we have to use a string here! */
+ return(StackAddFeedback("", "Interval_wrongnumargs", stack_disp(string(ex), "i"))),
+ iop:op(ex),
+ il:first(args(ex)),
+ ir:second(args(ex)),
+ if real_numberp(il) and real_numberp(ir) and is(ir<il) then
+ ret:StackAddFeedback(ret, "Interval_backwards", stack_disp(ex, "i"), stack_disp(apply(iop,[ir, il]), "i")),
+ return(ret)
+)$
+
+/* Validate a realset, mostly for student feedback, so no errors thrown. */
+interval_validate_realset(ex) := block(
+ if trivialintervalp(ex) then return(""),
+ if setp(ex) then return(""),
+ if intervalp(ex) then return(interval_validate_single_interval(ex)),
+ if safe_op(ex)="%union" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ if safe_op(ex)="%intersection" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ return(StackAddFeedback("", "Interval_illegal_entries", stack_disp(ex, "i")))
+)$
+
+cc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right]")
+)$
+texput(cc, cc_interval_tex)$
+
+/* Note, the mismatching square brackets play havoc with the PHP interface. */
+co_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right)")*/
+ concat("!LEFTSQ! ", tex1(a),",\\, ",tex1(b), "!RIGHTR!")
+)$
+texput(co, co_interval_tex)$
+
+oc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right]")*/
+ concat("!LEFTR! ", tex1(a),",\\, ",tex1(b), "!RIGHTSQ!")
+)$
+texput(oc, oc_interval_tex)$
+
+oo_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right)")
+)$
+texput(oo, oo_interval_tex)$
+
+realset_tex(ex) := block([a, b, c],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ c:ev(interval_complement(b), simp),
+ if safe_setp(c) then
+ concat("{", tex1(a), " \\not\\in {",tex1(c), "}}")
+ else
+ concat("{", tex1(a), " \\in {",tex1(b), "}}")
+)$
+texput(realset, realset_tex)$
+
+/* Returns True if p is an element of A. False, otherwise: */
+
+inintervalp(p, A) := block ([Ans, Args, x, y, Atemp, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ Ans:false,
+ if not ev(real_numberp(p), simp) then
+ error("intervals: ",p," should be a real number"),
+
+ if atom(A) then Ans:false
+ elseif op(A)=set then
+ (
+ Atemp:listify(A),
+ n:length(Atemp),
+ while i<(n+1) do
+ (
+ if p=Atemp[i] then Ans:true,
+ i:i+1 )
+ )
+ elseif not( op(A)="[" ) then
+ (
+ Args:args(A),
+ x:first(Args),
+ y:last(Args),
+ if op(A)=cc then
+ (
+ if (p>=x and p<=y) then Ans:true
+ ),
+ if op(A)=oo then
+ (
+ if (p>x and p<y) then Ans:true
+ ),
+ if op(A)=co then
+ (
+ if (p>=x and p<y) then Ans:true
+ ),
+ if op(A)=oc then
+ (
+ if (p>x and p<=y) then Ans:true
+ )
+ )
+ elseif op(A)="[" then
+ (
+ n:length(A),
+ while j<n+1 do
+ (
+ Atemp:A[j],
+ Ans:inintervalp(p,Atemp),
+ if Ans=false then j:j+1 else j:n+1
+ )
+ )
+ else error("intervals: the interval, ",A,", is not of a recognised form"),
+ Ans
+)$
+
+intervalp(X) := block([A:X, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1)],
+ if atom(A) then return(false),
+
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+ if (op(A)=cc or op(A)=oo or op(A)=co or op(A)=oc) then return(true),
+ false
+)$
+
+realsetp(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(all_listp(real_numberp, args(ex))),
+ if intervalp(ex) then return(all_listp(real_numberp, args(ex))),
+ if op(ex)=%union then return(all_listp(realsetp, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realsetp, args(ex))),
+ return(false)
+)$
+
+/* Does not require all numbers to be actual real numbers. */
+realset_soft_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(realset_soft_p, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realset_soft_p, args(ex))),
+ return(false)
+)$
+
+/* Only looks at the very top level, used for validation */
+realset_surface_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(true),
+ if op(ex)=%intersection then return(true),
+ return(false)
+)$
+
+/* Make a real set, taking edge cases into account. This is also a top level function to convert true/false into all/none. */
+realsetmake(v, ex) := block(
+ if is(ex=false) then return(none),
+ if is(ex={}) then return(none),
+ if is(ex=%union()) then return(none),
+ if is(ex=%intersection()) then return(none),
+ if is(ex=true) then return(all),
+ if is(ex=all) or is(ex=none) or is(ex=unknown) then return(ex),
+ if atom(ex) then return(ex),
+ if is(safe_op(ex)="realset") then return(ex),
+ return(realset(v, ex))
+)$
+
+/* Predicate to remove trivial cases like oo(a,a) and co(-inf, -inf). */
+trivialintervalp(ex) := block(
+ if is(ex=all) or is(ex=none) then return(true),
+ if safe_setp(ex) and ex={} then return(true),
+ if not(intervalp(ex)) then return(false),
+ if safe_op(ex)="oo" and first(ex)=second(ex) then return(true),
+ if first(ex)=inf then return(true),
+ if second(ex)=-inf then return(true),
+ return(false)
+)$
+
+/* Return the number of separate connected components. */
+interval_count_components(ex) := block(
+ if not(realsetp(ex)) then error("interval_count_components"),
+ if ex=all then return(1),
+ if trivialintervalp(ex) then return(0),
+ if intervalp(ex) then return(1),
+ if setp(ex) then return(cardinality(ex)),
+ ev(apply("+", map(interval_count_components, args(ex))), simp)
+)$
+
+interval_simple_union(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then
+ Ans:B
+ elseif atom(B) then
+ Ans:A
+ elseif safe_setp(A) then (
+ if safe_setp(B) then
+ Ans:union(A,B)
+ else (
+ Args1:args(B),
+ x1:first(Args1),
+ y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if (Aset[i]<x1 or Aset[i]>y1) 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:i+1
+ ),
+ 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]<x1 or 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:i+1
+ ),
+ 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:false,
+ if first(Args1)=first(Args2) then (
+ if ( op(A)=co or op(A)=cc ) then
+ swap:false
+ elseif ( op(B)=co or op(B)=cc ) then
+ swap:true
+ else swap:false
+ ),
+ 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 (x2<y1 and y2>y1) 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 (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:interval_simple_union( A , {y2} )
+ else
+ Ans:A
+ ),
+ if (x2<y1 and y2<y1) then
+ Ans:A,
+ if x2=y1 then (
+ if ( (op(A)=co or op(A)=oo) and (op(B)=oo or op(B)=oc) ) then
+ Ans:[A,B]
+ else (
+ 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)
+ )
+ )
+ )
+ )
+ ),
+ Ans
+)$
+
+
+/* Finds the intersection of two "simple" real sets. */
+interval_simple_intersect(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, lopen:false, ropen:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+ if safe_setp(A) and safe_setp(B) then return(intersect(A,B)),
+ /* A & B are not both sets. */
+ if safe_setp(B) then (
+ A:Y,
+ B:X
+ ),
+ if safe_setp(A) then (
+ Args1:args(B),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if inintervalp(Aset[i],B) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 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:false,
+ if first(Args1)=first(Args2) then (
+ if (op(A)=co or op(A)=cc) then (
+ swap:false
+ ) elseif (op(B)=co or op(B)=cc ) then (
+ swap:true
+ ) else (
+ swap:false
+ )
+ ),
+ if is(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 (x2<y1 and y2>y1) 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 (x2<y1 and y2<y1) then
+ Ans:B,
+ if (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=oo) then lopen:true,
+ if (op(B)=oo or op(B)=co or op(A)=oo or op(A)=co) then ropen:true,
+ if (lopen and ropen) then Ans:oo(x2,y1),
+ if (lopen and not ropen) then Ans:oc(x2,y1),
+ if (not lopen and ropen) then Ans:co(x2,y1),
+ if (not lopen and not ropen) then Ans:cc(x2,y1)
+ ),
+ if x2=y1 then (
+ if ((op(A)=cc or op(A)=oc) and (op(B)=co or op(B)=cc)) then
+ Ans:{x2}
+ else
+ Ans:{}
+ ),
+ Ans
+)$
+
+interval_disjointp(A, B) := if interval_simple_intersect(A, B)={} then true else false$
+
+/* Is the ex1 contained within the real set ex2? */
+interval_subsetp(ex1, ex2) := block(
+ if not(realsetp(ex1)) then error("interval_subsetp expects its first argument to be a real set."),
+ if not(realsetp(ex2)) then error("interval_subsetp expects its second argument to be a real set."),
+ if interval_intersect(ex1, ex2) = ex1 then true else false
+)$
+
+/* Is the simple interval ex a explicitly a subinterval of EX? */
+interval_containsp(ex, EX) := block(
+ if not(intervalp(ex)) then error("interval_containsp expects its first argument to be a simple interval."),
+ if not(realsetp(EX)) then error("interval_containsp expects its second argument to be a real set."),
+ if is(ex=EX) then return(true),
+ if not(safe_op(EX)="%union" or safe_op(EX)="%intersection") then return(false),
+ if elementp(ex,setify(args(EX))) then return(true),
+ return(false)
+)$
+
+/* Top level intersection function which takes real sets, such as %unions. */
+interval_intersect(X,Y) := block([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if safe_op(A)="%intersection" then A:interval_intersect_list(args(A)),
+ if safe_op(B)="%intersection" then B:interval_intersect_list(args(B)),
+
+ if is(A=all) then return(B),
+ if is(B=all) then return(A),
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if not(listp(A)) and not(listp(B)) then return(interval_simple_intersect(A,B)),
+
+ /* Ensure we have lists to deal with, by making them lists of one element if needed. */
+ if not(listp(A)) then (temp:[], A:cons(A,temp) ),
+ if not(listp(B)) then (temp:[], B:cons(B,temp) ),
+
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (
+ A:A[1],
+ B:B[1],
+ return(interval_simple_intersect(A,B))
+ ) else (
+ while i<m+1 do (
+ while j<n+1 do (
+ temp:interval_simple_intersect(A[i], B[j]),
+ if not atom(temp) then (
+ Ans:append(Ans, [temp])
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ ),
+ if listp(Ans) then (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ ),
+ interval_tidy(Ans)
+)$
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+interval_intersect_list(X) :=
+ block ( [A:X, Ans, n, i, simp],
+ simp:true,
+ if X=[] then return({}),
+ n:length(A),
+ if n=1 then return(first(A)),
+ Ans:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ Ans:interval_intersect(Ans, A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+interval_intersect_nary([X]) := interval_intersect_list(X)$
+
+/* Given intervals, returns the same intervals but in ascending order of the first element in the interval. */
+interval_sort(X) := block([A:X, Ans:[], x, n, i],
+ if safe_op(X) = "%union" then A:args(X),
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do block(
+ if is(first(A[i]) < first(x)) then x:A[i],
+ i:ev(i+1,simp)
+ ),
+ Ans:append(Ans,[x]),
+ A:delete(x, A, 1),
+ n:ev(n-1, simp)
+ ),
+ /* %union does things to its arguments like moving -inf to the right with simp:true. */
+ /* Return a list to avoid killing the order here. */
+ Ans
+);
+
+/* Given a union of disjoint intervals,
+ checks whether any intervals are connected, and if so, joins them up and returns the ammended union. */
+interval_connect(X) := block([Ans, n, x, y, i:1],
+ if not(op(X)=%union or listp(X)) then error("interval_connect requires a %union or list of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ i:ev(i,simp),
+ if last( Ans[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:i+1
+ ),
+ 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],
+ if atom(X) then return(Ans:phi),
+ if listp(X) then X:apply(%union, X),
+ X:ev(X, %intersection=interval_intersect_nary),
+
+ if not(op(X)=%union or listp(X)) then (
+ Ans:X
+ ) else (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<ev(n+1, simp) do (
+ i:ev(i,simp),
+ if safe_setp(A[i]) then (
+ setpart:union(setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ) else if trivialintervalp(A[i]) then (
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ),
+ i:ev(i+1, simp)
+ ),
+ A:interval_sort(A),
+ if is(length(A)>1) 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
+ ),
+ 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 i<n+1 do
+ (
+ if length(setpart)>0 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:i+1
+ )
+ )
+ else Ans:A,
+ Ans
+)$
+
+/* Return the set complement of a real set. */
+interval_complement(X):= block([A:X, Ans:[], x, y, 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 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<n do (
+ temp:oo( A[i], A[i+1] ),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ i:i+1
+ ),
+ temp:oo(A[n], inf),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ apply(%union, Ans)
+)$
+
+/* Turns a single variable system over the reals in to a set of real numbers, together with insoluable bits (if any). */
+single_variable_solver_real(ex) := block([v, rs1, rs2],
+ if is(ex=false) then return(none),
+ if is(ex=true) then return(all),
+ if atom(ex) then return(ex),
+ v:listofvars(ex),
+ if is(length(v)=0) then block
+ (
+ if is(ratsimp(lhs(ex)-rhs(ex))=0) then
+ ex:all
+ else
+ ex:none
+ ),
+ if not(length(v)=1) then return(ex),
+ v:first(v),
+ ex:abs_replace_eq(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),
+
+ /* Notes,
+ (1) assume_pos automatically removes terms like v>=0 in the simplifier.
+ (2) we do need simplification here to reduce execution time.
+ */
+
+ if assume_pos then
+ ex:block([assume_pos:false], ev(single_variable_solver_real_rec(ex %and (v>=0), v), simp))
+ else
+ ex:ev(single_variable_solver_real_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),
+ rs1:realsetmake(v, rs1),
+ if is(rs1=none) then
+ ex:apply("%or", rs2)
+ else if is(rs1=all) then
+ ex:all
+ else
+ ex:realsetmake(v, rs1) %or apply("%or", rs2)
+ ),
+ if safe_op(ex)="%union" or safe_setp(ex) then
+ ex:realsetmake(v, ex),
+
+ return(ex)
+)$
+
+single_variable_solver_real_rec(ex, v) := block([r0, r1, r2],
+ if atom(ex) then return(ex),
+ if intervalp(ex) then return(ex),
+
+ if equationp(ex) then return(ev(equation_to_intervals(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], single_variable_solver_real_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)
+)$
+
+equation_to_intervals(ex, v) := block([sol0, sol1, sol2],
+ sol0: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),
+ sol1:flatten(setify(sol1)),
+ if is(length(sol2)=1) then
+ sol2:first(sol2)
+ else
+ sol2:apply("%or", sol2),
+ if emptyp(sol1) then
+ return(sol2),
+ return(sol1 %or sol2)
+)$
+
+/* Calculate the natural domain of a single-variable term. */
+natural_domain(ex) := block([v, ex2],
+ 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),
+ realsetmake(v, ex2)
+)$
+
+/* 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(single_variable_solver_real(first(args(ex))>=0)),
+ if safe_op(ex)="ln" or safe_op(ex)="log" or safe_op(ex)="lg" then
+ return(single_variable_solver_real(first(args(ex))>0)),
+ if safe_op(ex)="/" then
+ ex2:[natural_domain_rec(first(args(ex))), single_variable_solver_real((second(args(ex))>0) %or (second(args(ex))<0))]
+ else
+ 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),
+ ex2
+)$
diff --git a/stack/2020052700/maxima/noun_arith.lisp b/stack/2020052700/maxima/noun_arith.lisp
new file mode 100644
index 0000000..eff2e25
--- /dev/null
+++ b/stack/2020052700/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 $noun+ tex-mplus tex)
+(defprop $noun+ ("+") texsym)
+(defprop $noun+ 100. tex-lbp)
+(defprop $noun+ 100. tex-rbp)
+
+(defprop $noun- tex-prefix tex)
+(defprop $noun- ("-") texsym)
+(defprop $noun- 100. tex-rbp)
+(defprop $noun- 100. tex-lbp)
+
+(defprop $noun* tex-nary tex)
+(defprop $noun* "\\," texsym)
+(defprop $noun* 120. tex-lbp)
+(defprop $noun* 120. tex-rbp)
+
+(defprop $noun/ tex-mquotient tex)
+(defprop $noun/ 122. tex-lbp) ;;dunno about this
+(defprop $noun/ 123. tex-rbp)
+
+(defprop $noun^ tex-mexpt tex)
+(defprop $noun^ 140. tex-lbp)
+(defprop $noun^ 139. tex-rbp)
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+(defprop $nounand 65. tex-lbp)
+(defprop $nounand 65. tex-rbp)
+;;(defprop mand ("\\land ") texsym)
+(defprop mand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+(defprop $nounor 61. tex-lbp)
+(defprop $nounor 61. tex-rbp)
+;;(defprop mor ("\\lor ") texsym)
+(defprop mor ("\\,{\\mbox{ !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/2020052700/maxima/rtest_assessment_simpboth.mac b/stack/2020052700/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000..bc02f60
--- /dev/null
+++ b/stack/2020052700/maxima/rtest_assessment_simpboth.mac
@@ -0,0 +1,373 @@
+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'); ",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! ); ",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'); ",false]$
+irred_Q(9-3*x+3*x^5,x);
+[false,"stack_trans('irred_Q_commonint'); ",true]$
+
+irred_power_Qp(2,x);
+true$
+irred_power_Qp((x-1)^2,x);
+true$
+irred_power_Qp((3*x-6)^4,x);
+true$
+irred_power_Qp(x^2-1,x);
+false$
+irred_power_Qp(3*x-6*x^3+3*x^6,x);
+false$
+irred_power_Qp(9-3*x+3*x^5,x);
+true$
+
+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{false}\\)"$
+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]$
+
diff --git a/stack/2020052700/maxima/rtest_assessment_simpfalse.mac b/stack/2020052700/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000..e4228b9
--- /dev/null
+++ b/stack/2020052700/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*(1/x+1/1)$
+buggy_pow( 3*(x+1)^-2 );
+3*(1/x^2+1/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/2020052700/maxima/rtest_assessment_simptrue.mac b/stack/2020052700/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000..6f71fbf
--- /dev/null
+++ b/stack/2020052700/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/2020052700/maxima/rtest_elementary.mac b/stack/2020052700/maxima/rtest_elementary.mac
new file mode 100644
index 0000000..f0034a8
--- /dev/null
+++ b/stack/2020052700/maxima/rtest_elementary.mac
@@ -0,0 +1,179 @@
+zeroAdd(x);
+x$
+zeroAdd(0+x);
+x$
+zeroAdd(0+0+x);
+0+x$
+zeroAdd(x+0);
+x+0$
+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);
+x*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*1$
+oneMul(1^x);
+1^x$
+oneMul(x^1);
+x^1$
+oneMul(1*1*x);
+1*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$
+
+zPow(1);
+1$
+zPow(x^0);
+1$
+zPow(0^x);
+0^x$
+zPow(0^0);
+0^0$
+zPow(1+x);
+1+x$
+
+unaryAdd(x);
+x$
+unaryAdd("+"(x));
+x$
+unaryAdd("*"(x));
+"*"(x)$
+unaryAdd("+"(x,y));
+x+y$
+
+unaryMul("*"(x));
+x$
+unaryMul("*"(x,y));
+x*y$
+
+
+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$
+
+negNeg(x);
+x$
+negNeg(-x);
+-x$
+negNeg(-(-x));
+x$
+
+negZero(-x);
+-x$
+negZero(-0);
+0$
+negZero("-"(0));
+0$
+
+negDef(a-a);
+0$
+negDef(a+b-a);
+b$
+negDef(a-a-a);
+-a$
+negDef(a-a+b-b);
+0$
+
+negDistAdd(-(a+b));
+-a-b$
+
+intAdd(1+2);
+3$
+intAdd(1+x+2);
+x+3$
+
+intMul(2*3);
+6$
+intMul(2*x*3);
+6*x$
+
+intPow(2^3);
+8$
+intPow(2^x);
+2^x$
+intPow(0^0);
+0^0;
+
+
+
+
+
diff --git a/stack/2020052700/maxima/rtest_experimental.mac b/stack/2020052700/maxima/rtest_experimental.mac
new file mode 100644
index 0000000..e69de29
diff --git a/stack/2020052700/maxima/rtest_inequalities.mac b/stack/2020052700/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000..2498d27
--- /dev/null
+++ b/stack/2020052700/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)$
+1<x$
+
+inequality_disp(x-1<=%pi)$
+x<=1+%pi$
+
+inequality_disp(x>1);
+1<x$
+
+inequality_disp(2*x>%pi);
+%pi/2<x$
+
+inequality_disp(x>=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^2<x);
+x^2>x;
+
+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<x;
+
+rev_ineq(x>=6);
+6<=x;
+
+rev_ineq(x^2<x);
+x>x^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 6<x));
+x>6 and y>2$
+
+ineq_rem_redundant(1<x and x<%pi and x<20);
+x>1 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/2020052700/maxima/rtest_intervals.mac b/stack/2020052700/maxima/rtest_intervals.mac
new file mode 100644
index 0000000..b540ba0
--- /dev/null
+++ b/stack/2020052700/maxima/rtest_intervals.mac
@@ -0,0 +1,161 @@
+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/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(-1,-1/2),oo(-1/2,inf),oo(-inf,-1)))$
+
+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((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)))$
+
+single_variable_solver_real(x^2-4>0);
+realset(x,%union(oo(2,inf),oo(-inf,-2)))$
+
+single_variable_solver_real(2*x/abs(x-1)<1);
+(1-(2*x)/(x-1) > 0) %or ((2*x)/(x-1)+1 > 0)$
+
+single_variable_solver_real(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),{3},oc(-inf,0))$
+
+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/2020052700/maxima/sandbox.wxm b/stack/2020052700/maxima/sandbox.wxm
new file mode 100644
index 0000000..bd88b25
--- /dev/null
+++ b/stack/2020052700/maxima/sandbox.wxm
@@ -0,0 +1,85 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 13.04.2 ] */
+
+/* [wxMaxima: title start ]
+STACK Sandbox
+ [wxMaxima: title end ] */
+
+/* [wxMaxima: comment start ]
+This document loads the extra files needed for STACK.
+See https://github.com/maths/moodle-qtype_stack
+
+1. Set your operation system in the variable maximaplatform. For Windows set it to "win".
+2. If needed, set the stacklocation variable to the location of this sandbox file and the needed maxima and lisp files.
+3. 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 ] */
+/* No trailing slash. */
+maximaplatform:"linux"$
+stacklocation:"."$
+stacktmplocation:"/tmp"$
+
+/* For MS platforms you normally need to explicitly set the path.
+ Use the forward slash as a directory seperator.
+ You have cloned your code into c:/tmp/stackroot
+*/
+/*
+maximaplatform:"win"$
+stacklocation:"c:/tmp/stackroot/stack"$
+*/
+
+
+/****************************************************
+ 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, "/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/maxima/###.{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)$
+
+STACK_SETUP(ex):=block(
+ MAXIMA_VERSION_NUM_EXPECTED:41.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:"del",
+ GNUPLOT_CMD:"C:\\bin\\moodle\\server\\moodledata\\stack\\wgnuplot.exe",
+ MAXIMA_VERSION_EXPECTED:"5.42.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, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, 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, 0.01*Sv, m^2/s^2, 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{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}"],
+ stack_unit_other_unit_code:[min, amu, u, mmHg, bar, cc, gal, mbar, atm, torr, rev, deg, rpm, K, day, year, in, ft, mi],
+ stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 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), K, 86400*s, 3.156e7*s, in, 12*in, 5280*12*in],
+ stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{K}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{mi}"],
+ true)$
+/* Load the main libraries. */
+load("stackmaxima.mac")$
+load("stats")$
+load("distrib")$
+load("descriptive")$
+print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$
+/* [wxMaxima: input end ] */
+
+/* [wxMaxima: input start ] */
+/* Optional but useful. */
+display2d:true;
+simp:false;
+debug:true;
+/* [wxMaxima: input end ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2020052700/maxima/stack_logic.lisp b/stack/2020052700/maxima/stack_logic.lisp
new file mode 100644
index 0000000..2a1e162
--- /dev/null
+++ b/stack/2020052700/maxima/stack_logic.lisp
@@ -0,0 +1,678 @@
+#|
+; logic.mac--Logic algebra package for Maxima CAS.
+; Copyright (c) 2008--2009 Alexey Beshenov <al@beshenov.ru>.
+;
+; 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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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
+;
+;
+; TODO: 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/2020052700/maxima/stackmaxima.mac b/stack/2020052700/maxima/stackmaxima.mac
new file mode 100644
index 0000000..df2deda
--- /dev/null
+++ b/stack/2020052700/maxima/stackmaxima.mac
@@ -0,0 +1,3185 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/* ********************************** */
+/* 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,
+ /* 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,
+
+ 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);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* Corresponds to current student expectations */
+alias(cosech,csch); /* Corresponds to current student expectations */
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+
+/* TODO: 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("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
+)$
+
+/* ********************************** */
+/* Load STACK packages */
+/* ********************************** */
+
+load("assessment.mac");
+load("inequalities.mac");
+load("intervals.mac");
+load("stackunits.mac");
+load("stacktex.lisp");
+load("stackstrings.mac");
+load("sregex");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+load("casanswertest.mac");
+load("errortostring.lisp");
+
+/* Breaks on older versions of Maxima. */
+if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+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 = "blank" then texput("*", "\\, ", nary)
+);
+
+make_logic(OPT_LOGIC) := block(
+ if OPT_LOGIC = "lang" then block(
+ texput("and", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("nounand", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("or", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nounor", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nand", "\\,{\\mbox{ !NAND! }}\\, ", nary),
+ texput("nor", "\\,{\\mbox{ !NOR! }}\\, ", nary),
+ texput("xor", "\\,{\\mbox{ !XOR! }}\\, ", nary),
+ texput("xnor", "\\,{\\mbox{ !XNOR! }}\\, ", nary),
+ texput("implies", "\\,{\\mbox{ !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)
+)$
+
+/* Options for cos^(-1), acos or arccos. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then block(
+ texput(asin, "\\sin^{-1}", prefix),
+ texput(acos, "\\cos^{-1}", prefix),
+ texput(atan, "\\tan^{-1}", prefix),
+ texput(asec, "{\\rm sec}^{-1}", prefix),
+ texput(acsc, "{\\rm csc}^{-1}", prefix),
+ texput(acot, "{\\rm cot}^{-1}", prefix),
+ texput(asinh, "{\\rm sinh}^{-1}", prefix),
+ texput(acosh, "{\\rm cosh}^{-1}", prefix),
+ texput(atanh, "{\\rm tanh}^{-1}", prefix),
+ texput(asech, "{\\rm sech}^{-1}", prefix),
+ texput(acsch, "{\\rm csch}^{-1}", prefix),
+ texput(acoth, "{\\rm coth}^{-1}", prefix)
+ ),
+ if OPT_ACOS = "arccos" then block(
+ texput(asin, "\\arcsin ", prefix),
+ texput(acos, "\\arccos ", prefix),
+ texput(atan, "\\arctan ", prefix),
+ texput(asec, "{\\rm arcsec}", prefix),
+ texput(acsc, "{\\rm arccsc}", prefix),
+ texput(acot, "{\\rm arccot}", prefix),
+ texput(asinh, "{\\rm arcsinh}", prefix),
+ texput(acosh, "{\\rm arccosh}", prefix),
+ texput(atanh, "{\\rm arctanh}", prefix),
+ texput(asech, "{\\rm arcsech}", prefix),
+ texput(acsch, "{\\rm arccsch}", prefix),
+ texput(acoth, "{\\rm arccoth}", prefix)
+ ),
+ if OPT_ACOS = "acos" then block(
+ texput(asin, "{\\rm asin}", prefix),
+ texput(acos, "{\\rm acos}", prefix),
+ texput(atan, "{\\rm atan}", prefix),
+ texput(asec, "{\\rm asec}", prefix),
+ texput(acsc, "{\\rm acsc}", prefix),
+ texput(acot, "{\\rm acot}", prefix),
+ texput(asinh, "{\\rm asinh}", prefix),
+ texput(acosh, "{\\rm acosh}", prefix),
+ texput(atanh, "{\\rm atanh}", prefix),
+ texput(asech, "{\\rm asech}", prefix),
+ texput(acsch, "{\\rm acsch}", prefix),
+ texput(acoth, "{\\rm acoth}", prefix)
+ )
+);
+
+
+/* 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);
+
+/* ****************************************************** */
+/* 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(
+ 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)
+)$
+
+/* Make a random selection of n different items from the list ex. */
+/* CJS, 7/6/2016 */
+rand_selection(ex, n) := block(
+ if not(listp(ex)) then (
+ error("rand_selection error: first argument must be a list."),
+ 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."),
+ 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)
+)$
+
+/* 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)<numcor then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ return([ta, version])
+)$
+
+/* Helper function for constructing MCQ arrays with auto-generated alphabetic labels. Students choose the labels. */
+multiselqnalpha([exs]):=block([corbase, numcor, wrongbase, numwrong, dispflag, ta1, ta2, ta3, talab, ta, version],
+ if length(exs)<4 then error("multiselqnalpha must have at least four arguments."),
+ corbase:first(exs),
+ numcor:second(exs),
+ wrongbase:third(exs),
+ numwrong:fourth(exs),
+ dispflag:"id",
+ if length(exs)>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)<numcor then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta3: random_permutation(append(ta1, ta2)),
+ /* Add in a slightly different display here. */
+ talab: ev(makelist(sconcat("(",ascii(96+i),")"), i, 1, length(ta3)), simp),
+ ta:zip_with(lambda([ex1, ex2], [ex1, ex2[2], sconcat("<b>", ex1, "</b> ",
+ 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)<numcor then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ /* */
+ corbase: zip_with("[", ev(makelist(k,k,1,length(corbase)),simp), corbase),
+ wrongbase: zip_with("[", ev(makelist(k,k,1+length(corbase),1+length(corbase)+length(wrongbase)),simp), wrongbase),
+ ta1: maplist(lambda([ex], [first(ex), true, second(ex)]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [first(ex), false, second(ex)]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ /* */
+ return([ta, version])
+)$
+
+/* Helper functions for MCQ arrays. */
+mcq_correct(ta):=block(
+ if not(listp(ta)) then error("mcq_correct: first argument must be a list, but was passed: ", string(ta)),
+ if not(all_listp(listp, ta)) then error("mcq_correct: 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_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)))))
+)$
+
+/* ********************************** */
+/* 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]])$
+
+/* 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],
+ %_tmp:[[_k, stack_dispvalue(_v)]],
+ if listp(%_tmp) then _DVALUES:append(_DVALUES,%_tmp),
+ 0)$
+_CS2dvv(_k,_v) := (_CS2v(_k,_v),_CS2dv(_k,_v),0)$
+
+/* ********************************** */
+/* Display */
+/* ********************************** */
+/* expr - expression to be displayed */
+/* m - mode, either */
+/* "i" inline or */
+/* "d" for displayed, or */
+/* "" for no delimiters. */
+/* ********************************** */
+
+stack_disp(expr, exprm) := block([str:"", expru],
+ /* LaTeX display */
+ if OPT_OUTPUT = "LaTeX" then
+ if not(ev(elementp(exprm, {"", "i", "d", "id"}), simp)) then print(concat("ERROR: illegal delimiter option found: ", exprm)),
+ /* Fine tune display, e.g. sort out display of atoms like theta0. */
+ expru: expr,
+ if not(stack_disp_control_structurep(expr)) then block(
+ expru: unary_minus_sort(expr),
+ expru: stack_disp_sub_script(expru)),
+
+ str: block([expstr, offset, ld, rd],
+ ld: "",
+ rd: "",
+ if exprm = "i" then block(ld: "\\(", rd:"\\)"),
+ if exprm = "id" then block(ld: "\\(\\displaystyle ", rd:"\\)"),
+ if exprm = "d" then block(ld: "\\[", rd:"\\]"),
+ mminusbp100(true),
+ expstr: tex(expru, false),
+ mminusbp120(true),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* String display */
+ if OPT_OUTPUT = "String" then str: string(expr),
+ /* If no correct options have been set. */
+ if str = "" then str:string(expr),
+ return(str)
+)$
+/* This function was renamed to improve the consistency of the coding style. */
+/* We continue to support the old name, since question authors may have used */
+/* it, even though that was not recommended practice. */
+alias(StackDISP, stack_disp)$
+
+/* If an expression contains these control structures then we don't fine-tune the display. */
+stack_disp_control_structurep(ex) := not(freeof(?mdoin, ?mdo, ?mcond, catch, throw, ":=", lambda, setelmx, ex))$
+
+stack_disp_strip_dollars(ex) := block(
+ if ?subseq(ex, 0, 2) = "$$" then
+ ex:?subseq(ex, 2, ev(?length(ex)-3, simp))
+ /* Remove \begin{verbatim}'s from Maxima's TEX command */
+ else if ?length(ex) > 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";
+?texnumformat(x) := if ev(floatnump(x),simp) then
+ ev(printf(false, stackfltfmt, x), simp) else if ev(integerp(x),simp) then (
+ if (is(stackintfmt="~r") or is(stackintfmt="~:r")) then
+ sconcat("\\mbox{",ev(printf(false, stackintfmt, x), simp),"}")
+ else
+ ev(printf(false, stackintfmt, x), simp)
+ ) else
+ string(x);
+/* 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),
+ 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..... */
+
+/* ******************************************* */
+/* Validate an expression */
+/* ******************************************* */
+
+/* List of variables, without some specific tokens in. */
+stack_validate_listofvars(ex) := block([lvars],
+ lvars:ev(setify(listofvars(ex)), simp),
+ lvars:ev(setdifference(lvars,{null, QMCHAR, EMPTYANSWER}), simp),
+ lvars:ev(sort(listify(lvars)), simp)
+)$
+
+stack_validate(expr, LowestTerms, TAns) := block([simp:false, exs, SameType, 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"),
+ 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 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, Equiv, fltfmt) := block([simp:false, exs, fvs, fvs1, fvs2],
+ /* If we have a float format, then use it. */
+ if not(is(fltfmt=false)) then
+ stackfltfmt:fltfmt,
+ /* 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 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])
+)$
+
+/* *************************************/
+/* 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],
+ 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(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ 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],
+ /* 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. */
+ tn: string(absolute_real_time()),
+ filename:concat("stackplot","-",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("<img src='", URL_BASE, filename, ".", PLOT_TERMINAL, "' alt='", str_to_html(alttext), "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class='stack_plot'>", ufn, "</div>"),
+ ufn: concat(" <html>", ufn, "</html> "),
+ /* 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]])
+ ),
+ /* Add in the command for the grid. */
+ if plotgrid2d and MAXIMA_VERSION_NUM>34 then
+ ral: append(ral, [grid2d]),
+ /* Note, the axes option in Maxima doesn't seem to work.... */
+ 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),
+ 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. */
+ 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)
+)$
+
+/* ********************************** */
+/* Numerical operations */
+/* ********************************** */
+
+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_displaydp(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(TA) then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_number"))
+ else
+ if numtype = "ABSOLUTE" then
+ return([true, numabsolutep(SA, SB, tol), "", ""])
+ else
+ return([true, numrelativep(SA, SB, tol), "", ""]),
+
+ 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<ta-tol, then f1<0. */
+ /* if abs(sa-ta)<abs(tol), then f2<0. */
+ /* We appear to need to calulate f1 & f2 as variables, */
+ /* otherwise Maxima's is complains "undefined". Odd... */
+ sa:first(sal),
+ ta:first(tal),
+ if type="ABSOLUTE" then
+ (f1:ev(float(sa-ta+tol),simp),
+ f2:ev(float(abs(sa-ta)-abs(tol)), simp))
+ else
+ (f1:ev(float(sa-ta*(1-tol)),simp),
+ f2:ev(float(abs(sa-ta)-abs(ta*tol)), simp)),
+ /*print([sa,ta,f1,f2]),*/
+ if is(f1<0) then return(num_compare_helper(rest(sal), tal, missing, append([sa], excessive), tol, type)),
+ if is(f2<0)
+ then return(num_compare_helper(rest(sal), rest(tal), missing, excessive, tol, type)),
+ return(num_compare_helper(sal, rest(tal), append([ta], missing), excessive, tol, type))
+)$
+
+ATNumSigFigs(SA, SB, SO) := block([simp, Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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("","ATNumSigFigs_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+ if listp(ol) then
+ if length(ol)#2 then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_list_wrong_length"), StackAddFeedback("", "TEST_FAILED_Q")]))
+ else
+ (nsf:ol[1], asf:ol[2])
+ else (nsf:ol, asf:ol),
+ if ev(not(integerp(nsf) and integerp(asf)), simp) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* Remove ephemeral forms from teacher's answers. */
+ SB:remove_displaydp(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)
+)$
+
+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)
+ )$
+
+/* ********************************** */
+/* 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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)
+)$
+
+/* 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,
+ /* 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 algebraic_equivalence(SA, SB) then
+ RawMark:true
+ else if algebraic_equivalence(exdowncase(SA), exdowncase(SB)) then
+ AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase"),
+ ret:[Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+ )$
+
+/* 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,
+
+ /* Trap edge cases. */
+ 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 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", ""]),
+ 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 single_variable_solver_real(SA)=single_variable_solver_real(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(
+ 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(
+ /* TODO: 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)<length(SA)) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_duplicates"),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_duplicates")
+ ),
+
+ /* We check the simplified sets. */
+ if (subsetp(SAsimp, SBsimp) and subsetp(SBsimp, SAsimp)) then
+ return([true, true, AnswerNote, FeedBack]),
+
+ /* Can we give feedback on which are wrong ? */
+ if not(emptyp(setdifference(SAsimp, SBsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_wrongentries", stack_disp(setdifference(SAsimp, SBsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_wrongentries")
+ ),
+ if not(emptyp(setdifference(SBsimp, SAsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_missingentries", stack_disp(setdifference(SBsimp, SAsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_missingentries")
+ ),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+/* We don't put in boolean_form, or noun_logic_remove here because that breaks (pre-existing) inequalities and equations. */
+ATSets_prepare(S) := ev(map(lambda([ex], ineqprepare(trigreduce(ex)) ), S), simp)$
+
+
+/* Maxima regular expressions. */
+ATSRegExp(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, patmatched],
+ 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("","ATSRegExp_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATSRegExp_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SA_not_string")),
+
+ patmatched:regex_match(SBsimp, SAsimp),
+
+ if listp(patmatched) then
+ return([true, true, StackAddNote("", sconcat("ATSRegExp: ", string(patmatched))), FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+/* 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]])
+)$
+
+
+/* A general, all purpose answer test which checks things are of the
+ same "type". Based upon the results of AtAlgEquivfun(SA,SB)
+*/
+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(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("", "ATSubstEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SB:errcatch(ev(SB, simp, nouns)),
+ if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_TAns"), ""]),
+ SB:SB[1],
+ /* 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),
+ 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(single_variable_solver_real(SA), simp),
+ SBP:ev(single_variable_solver_real(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],
+
+ 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(sa,sb) then
+ (RawMark:true, AnswerNote:"")
+ else
+ (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")),
+
+ if SA=SB then
+ return([Validity, true, StackAddNote("","ATCASEqual_true"), FeedBack]),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(SA,SB),
+ if ret[2]=false then
+ return([true, false, StackAddNote("ATCASEqual ", StackTrimNote(ret[3])), ret[4]]),
+ ret:block([simp:true, ret], ATAlgEquivfun(SA, SB)),
+ 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 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],
+ deg:ev(hipow(expand(p),v),simp),
+ /* Now perform the general test */
+ cl:ev(map(second,coeff_list_nz(expand(p),v)),simp),
+ /* 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 deg=0 then ret:[true,"",false],
+ /* Special situation for the linear case to avoid strange results */
+ if 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 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)
+);
+
+/* Is p a power of an irreducible term in v, over the rationals Q, disregarding the special case of a numerical factor? */
+/* Only used by ATPartFrac */
+/* Returns true/false */
+irred_power_Qp(p,v) := block([ret],
+ if safe_op(p)="^" then ret:irred_Q(first(args(p)),v) else ret:irred_Q(p,v),
+ if third(ret) then true else first(ret)
+);
+
+/* Picks apart an expression p of v, and gives some feedback */
+/* on why this is not a factored expression */
+FacForm_UnPick(SA, SO) := block([negdistrib, PARTSWITCH, fb, kloop, irred, res],
+ negdistrib:false,
+ partswitch:true,
+ fb:"",
+ res:true,
+ if atom(SA) then return([true, ""]),
+ if safe_op(SA) = "-" then SA:part(SA,1),
+ 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 atom(SB) then return([true,""]),
+ if safe_op(SB) = "-" then SA:part(SB,1),
+ if op(SB) = "+" then return(irred_Q(SB, SO)),
+ if 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? */
+/* Assumes all coefficients are integers. */
+
+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],
+ if errcatch(deg:hipow(expand(SA), SO)) = [] then block(
+ val: false,
+ rawmk: false,
+ ansnote: StackAddNote("", "ATFacForm_error_degreeSA"),
+ fb: StackAddFeedback("", "ATFacForm_error_degreeSA")
+ ),
+ aequiv:algebraic_equivalence(SA, SB),
+ SA:flatten(SA),
+ /* An integer answer is always correct. */
+ if (integerp(SA)) then
+ if (SA=SB) then
+ ansnote: StackAddNote("", "ATFacForm_int_true")
+ else block(
+ rawmk: false,
+ ansnote: StackAddNote("", "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 ( /* We need to provide some feedback, if possible */
+ ansnote:StackAddNote(ansnote, "ATFacForm_isfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_isfactored")
+ )
+ else
+ (up:FacForm_UnPick(SA, SO) ),
+ if (up[1]=false) then (
+ rawmk: false,
+ ansnote:StackAddNote(ansnote, "ATFacForm_notfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_notfactored"),
+ fb:concat(fb, up[2])
+ )
+ else
+ (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. */
+PartFracfun(sExpr, tExpr, wrt) := block([val, rawmk, ansnote, fb],
+ 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")
+ ),
+ /* ... with the degree(num)<degree(den) */
+ if not all_listp(lambda([ex],if denom(ex)=1 then true else is(ev(hipow(expand(num(ex)),wrt)<hipow(expand(denom(ex)),wrt),simp))),list) then
+ block(
+ rawmk: false,
+ ansnote:StackAddNote("","ATPartFrac_false_degree")
+ ),
+ /* We need to check that each denominator is the power of an irreducible factor */
+ /* Note the slight cludge to check if we have a numerical factor */
+ if not all_listp(lambda([ex],irred_power_Qp(denom(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)
+ )$
+
+/* ************************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, atoptions],
+ oldsimp:simp,
+ simp:false,
+ Validity:true, RawMark:false,
+ FeedBack:"", AnswerNote:"",
+ keepfloat:true,
+ /* Should we be fussy about the constant of integration? */
+ constint:true,
+ /* 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 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),
+ sbdisp:fourth(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, 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. */
+ATIntOptions(opts) := block([note, var, atopts, optdefaults],
+ note:"",
+ /* Add in default values for the options here. See ATIntOptionsHelper for details.*/
+ optdefaults:[true,[]],
+ if emptyp(opts) or not(is(length(opts)<4)) then return(["ATInt_STACKERROR_OptList", x, 0, true]),
+ var:first(opts),
+ atopts:ATIntOptionsHelper(rest(opts), optdefaults),
+ return(append([note, var], atopts))
+)$
+
+/* The second argument to this function is a list of all options in a *known order*.
+ We recurse over the list updating these. We seed the function with defualt values.
+ Options currenty are as follows:
+ [NOCONST, spdisp]
+ where
+ NOCONST = true or false. Are we strict in requiring a constant of integration?
+ 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.
+*/
+ATIntOptionsHelper(in, out) := block(
+ if emptyp(in) then return(out),
+ if is(first(in)=NOCONST) then return(ATIntOptionsHelper(rest(in), append([false], rest(out)))),
+ return(ATIntOptionsHelper(rest(in), [first(out), first(in)]))
+)$
+
+Intfun(SA, SB, SBdisp, constint, 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:false, 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("", "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)$
+
+/* Slight hack to compile these functions and hence suppress warnings. */
+load(linearalgebra);
+
+/* Stack expects some output with the version number the output happens at */
+/* maximalocal.mac after additional library loading */
+stackmaximaversion:2020052700$
diff --git a/stack/2020052700/maxima/stackreporting.mac b/stack/2020052700/maxima/stackreporting.mac
new file mode 100644
index 0000000..14f9dd7
--- /dev/null
+++ b/stack/2020052700/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/2020052700/maxima/stackstrings.mac b/stack/2020052700/maxima/stackstrings.mac
new file mode 100644
index 0000000..6d85976
--- /dev/null
+++ b/stack/2020052700/maxima/stackstrings.mac
@@ -0,0 +1,296 @@
+/* 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))
+)$
+
+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(i<slength(tmp)), simp) do (
+ c:charat(tmp, ev(i+1, simp)),
+ if is(mode="raw") then (
+ if is(c="[") then tokens:append(tokens,[_stackjson_tokens_list_open])
+ elseif is(c="]") then tokens:append(tokens,[_stackjson_tokens_list_close])
+ elseif is(c="{") then tokens:append(tokens,[_stackjson_tokens_dict_open])
+ elseif is(c="}") then tokens:append(tokens,[_stackjson_tokens_dict_close])
+ elseif is(c=":") then tokens:append(tokens,[_stackjson_tokens_key_sep])
+ elseif is(c=",") then tokens:append(tokens,[_stackjson_tokens_list_sep])
+ elseif is(c="\"") then (mode:"string",lastslash:false,r:"")
+ elseif is(c="n") and is(charat(tmp,i+2)="u") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="l") then (i:i+3, tokens:append(tokens,[und]))
+ elseif is(c="t") and is(charat(tmp,i+2)="r") and is(charat(tmp,i+3)="u") and is(charat(tmp,i+4)="e") then (i:i+3, tokens:append(tokens,[true]))
+ elseif is(c="f") and is(charat(tmp,i+2)="a") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="s") and is(charat(tmp,i+5)="e") then (i:i+4, tokens:append(tokens,[false]))
+ elseif not is(sposition(c,sconcat(ascii(32),ascii(9),ascii(10),ascii(11),ascii(12),ascii(13)))=false) then (i:i)
+ elseif is(c="-") then (mode:"number",r:["-"])
+ elseif digitcharp(c) then (mode:"number",r:[c])
+ ) elseif is(mode="string") then (
+ if(lastslash) then (
+ lastslash:false,
+ if is(c="\\") then r:sconcat(r,"\\")
+ elseif is(c="n") then r:sconcat(r,ascii(10))
+ elseif is(c="t") then r:sconcat(r,ascii(9))
+ elseif is(c="r") then r:sconcat(r,ascii(13))
+ elseif is(c="b") then r:sconcat(r,ascii(8))
+ elseif is(c="f") then r:sconcat(r,ascii(12))
+ elseif is(c="\"") then r:sconcat(r,"\"")
+ elseif is(c="u") then (r:sconcat(r,unicode(stack_string_hex_to_num(substring(tmp,i+2,i+6)))),i:i+4)
+ else r:sconcat(r,c)
+ ) else (
+ if is(c="\\") then lastslash:true
+ elseif is(c="\"") then (tokens:append(tokens,[r]),mode:"raw")
+ else r:sconcat(r,c)
+ )
+ ) elseif is(mode="number") then (
+ if digitcharp(c) then r:append(r,[c])
+ elseif is(c=".") then r:append(r,[c])
+ elseif is(c="e") then r:append(r,[c])
+ elseif is(c="E") then r:append(r,[c])
+ elseif is(c="+") then r:append(r,[c])
+ elseif is(c="-") then r:append(r,[c])
+ else (tokens:append(tokens,[stack_string_parse_number(simplode(r))]),i:i-1,mode:"raw")
+ ),
+ i:i+1
+ ),
+
+ /* In the unlikely case that we have an atomic value e.g. string or number exit early. */
+ if is(length(tokens)=1) then return(tokens[1]),
+ dm:0,
+ /* Otherwise reduce grouppings. */
+ starts:sublist_indices(tokens, lambda([x], is(x=_stackjson_tokens_list_open) or is(x=_stackjson_tokens_dict_open))),
+ while ev(is(length(starts)>0), simp) do (
+ r:[],
+ nt:[],
+ i:1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<last(starts)), simp) do (nt:append(nt,[tokens[i]]), i:ev(i+1, simp)),
+ if is(tokens[last(starts)]=_stackjson_tokens_list_open) then (
+ i:last(starts)+1,
+ while not is(tokens[i]=_stackjson_tokens_list_close) do (
+ if not is(tokens[i]=_stackjson_tokens_list_sep) then r:append(r,[tokens[i]]),
+ i:ev(i+1, simp)
+ )
+ ) else (
+ r:["stack_map"],
+ i:ev(last(starts)+1, simp),
+ while not ev(is(tokens[i]=_stackjson_tokens_dict_close), simp) do (
+ if not ev(is(tokens[i]=_stackjson_tokens_list_sep), simp) then (
+ k:tokens[i],
+ v:tokens[ev(i+2, simp)],
+ r:append(r,[[k,v]]),
+ i:ev(i+3, simp)
+ ) else i:ev(i+1, simp)
+ )
+ ),
+ nt:append(nt,[r]),
+ i:i+1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<length(tokens)+1), simp) do (nt:append(nt,[tokens[i]]),i:ev(i+1, simp)),
+ if ev(is(length(nt)<length(tokens)), simp) then dm:0,
+ tokens:nt,
+ /* If the string is bad we may loop forever for this we have an automated exit. */
+ dm:ev(dm+1, simp),
+ if ev(is(dm>20), 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)
+)$
+
+
+/* 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"
+ else if stringp(obj) then (
+ tmp:ssubst("\\\\","\\",obj),
+ tmp:ssubst("\\\"","\"",tmp),
+ tmp:ssubst("\\b",ascii(8),tmp),
+ tmp:ssubst("\\t",ascii(9),tmp),
+ tmp:ssubst("\\n",ascii(10),tmp),
+ tmp:ssubst("\\f",ascii(12),tmp),
+ tmp:ssubst("\\r",ascii(13),tmp),
+ r:sconcat("\"",tmp,"\"")
+ ) 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(obj) then r:string(obj)
+ else if numberp(obj) then r:string(float(obj))
+ else r:stackjson_stringify(string(obj)),
+ return(r)
+)$
+
+
+/**
+ * Special tools for dealing with CASText2, absolutely no use
+ * if you are not running a system with CASText2.
+ *
+ * Even if you have CASText2 enabled system these tools are very
+ * advanced and probably not for a novice author. Essenttially,
+ * 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.
+ */
+ if is(ct2[1]="jsxgraph") 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]))
+)$
diff --git a/stack/2020052700/maxima/stacktex.lisp b/stack/2020052700/maxima/stacktex.lisp
new file mode 100644
index 0000000..c4fd3ed
--- /dev/null
+++ b/stack/2020052700/maxima/stacktex.lisp
@@ -0,0 +1,444 @@
+;; 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.
+;; If changes are made here, then we also need to update arccos.lisp
+
+(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 "\\mbox{ }"))
+ ((eql (elt x 0) #\\) x)
+ (t (concatenate 'string "\\mbox{" x "}"))))
+
+;; 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 %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)))
+
+;; insert left-angle-brackets for mncexpt. a^<n> 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
+ (not (member f '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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, 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))))))
diff --git a/stack/2020052700/maxima/stacktex40.lisp b/stack/2020052700/maxima/stacktex40.lisp
new file mode 100644
index 0000000..9a7c45e
--- /dev/null
+++ b/stack/2020052700/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^<n> 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 '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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/2020052700/maxima/stackunits.mac b/stack/2020052700/maxima/stackunits.mac
new file mode 100644
index 0000000..59062c9
--- /dev/null
+++ b/stack/2020052700/maxima/stackunits.mac
@@ -0,0 +1,598 @@
+/* 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 <http://www.gnu.org/licenses/>.
+*/
+
+
+/****************************************************************/
+/* Simplified tools for handling SI-units (+liters) */
+/* */
+/* Matti Harjula <matti.harjula@aalto.fi> */
+/* */
+/* Answer test added by */
+/* Chris Sangwin <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* V0.5 August 2016 */
+/****************************************************************/
+
+/* This code is commented out as these lists are now defined in the main code and
+ 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),
+ 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<bestc) then (best:va,bestc:vb)
+ )
+ ),
+ return(best)
+ ) else (
+ va:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*value))),
+ vb:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*target))),
+ ii:is(stack_units_units(va)!=stack_units_units(vb)),
+ va:stack_units_nums(va),
+ if is(va = NULLNUM) then
+ va:1,
+ vb:stack_units_nums(vb),
+ if is(vb = NULLNUM) then
+ vb:1,
+ conversionfactor:va/vb,
+ va:stack_units_nums(stackunits_make(value)),
+ if is(va = NULLNUM) then
+ va:1,
+ va:va*conversionfactor,
+ vb:stack_units_units(stackunits_make(target)),
+ if ii
+ then error("Units presentation requires compatible units.")
+ else return(stackunits(va,vb))
+ )
+)$
+
+/* Splits off the units from the end of a product. */
+stackunits_make(ex) := block([oldsimp, exn, exu, exl],
+ if (debug) then (print("stackunits_make: "), print(ex)),
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+ oldsimp:simp,
+ simp:false,
+ /* If we have only a number then return it, with a placeholder for units. */
+ if simp_numberp(float(ex)) then return(stackunits(ex, NULLUNITS)),
+ /* Atoms should be returned as just units. */
+ if atom(ex) then
+ return(stackunits(NULLNUM, ex)),
+ if safe_op(ex)="stackunits" then
+ return(ex),
+ if is_simp(op(ex)=STACKpmOPT) then return(block([numa,numb],
+ if length(args(ex))=1 then
+ (
+ numa:NULLNUM,
+ numb:first(args(ex))
+ )
+ else
+ (
+ numa:first(args(ex)),
+ numb:second(args(ex))
+ ),
+ if (debug) then print("stackunits_make: found +-. Preliminary split as ", print(numa), print(numb)),
+ numb:stackunits_make(numb),
+ if (debug) then print("stackunits_make: +- results give ", print(numa), print(numb)),
+ verb_arith(stackunits(numa, second(args(numb)),first(args(numb))))
+ )
+ ),
+ /* We have a special case x*1/s which we need to filter out at this stage. */
+ if safe_op(ex)="/" then
+ ex:stackunits_make_recip(ex),
+ exn:flatten_recurse_nouns(noun_arith(ex)),
+ if (debug) then (print("stackunits_make: nounarith expression is"), print(exn)),
+ /* If the student has indicated +- we deal with this. */
+ /* If we don't have units we are return what we are given. */
+ if is_simp(listofunits(ex)=[]) then
+ return(stackunits(ex, NULLUNITS)),
+ /* Edge case like s^(-1). */
+ if is_simp(op(exn)="noun^") then
+ exn:[exn] elseif not(is_simp(op(exn)="noun*")) then
+ return(stackunits(ex, NULLUNITS)),
+ exu:sublist(args(exn), lambda([ex2], not(stackunits_make_p(ex2)))),
+ exn:sublist(args(exn), lambda([ex2], stackunits_make_p(ex2))),
+ simp:oldsimp,
+ if (debug) then (print("stackunits_make: expressions split as"), print(exn), print(exu)),
+ /* Flag up if we genuinely have no numbers. */
+ if is_simp(emptyp(exn)) then
+ exn:[NULLNUM],
+ /* Flag up if we genuinely have no units. */
+ if is_simp(emptyp(exu)) then
+ exu:[NULLUNITS],
+ /* Transform (a^2)^-1 to a^(-2), for the units. */
+ exu:maplist(unary_minus_remove, exu),
+ exu:maplist(flatten_pow_minus_one, exu),
+ if (debug) then (print("stackunits_make: (1) reformulated units as "), print(exu)),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ exn:maplist(unary_minus_remove, exn),
+ exn:stack_units_rational_number(exn),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ if is(first(exn) = UNARY_MINUS) then
+ (
+ exn:rest(exn),
+ exn[1]:ev(-1*exn[1],simp)
+ ),
+ if length(exn)=1 then exn:first(exn) else exn:apply("noun*", exn),
+ if length(exu)=1 then exu:first(exu) else exu:apply("noun*", exu),
+ if (debug) then (print("stackunits_make: (3) reformulated units as "), print(exu)),
+ verb_arith(stackunits(exn, exu))
+)$
+
+/* This function is deprecated. NO NOT USE. */
+stack_units_split(ex) := args(stackunits_make(ex))$
+
+/* Turn stackunits into a product in a safe way. */
+stackunits_to_product(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ return(ex),
+ if stack_units_units(ex) = NULLUNITS then
+ return(stack_units_nums(ex)),
+ if stack_units_nums(ex) = NULLNUM then
+ return(stack_units_units(ex)),
+ apply("*", args(ex))
+)$
+
+/* Predicate function used as a filter in stackunits_make. */
+stackunits_make_p(ex) := block(
+ if simp_numberp(ex) or is_simp(ex=UNARY_MINUS) or is_simp(ex=QMCHAR) then
+ return(true),
+ if emptyp(listofvars(ex)) then
+ return(true),
+ if simp_numberp(ev(float(verb_arith(ex)), simp)) then
+ return(true),
+ return(false)
+)$
+
+/* Does something look like a rational number? */
+stack_units_rational_number(ex) := block(
+ if length(ex)=1 and safe_op(first(ex))="noun^" and is(second(args(first(ex)))=-1) then return([1/first(args(first(ex)))]),
+ if not(length(ex)=2) then
+ return(ex),
+ if not(integerp(first(ex))) or atom(second(ex)) then return(ex),
+ if safe_op(second(ex))="noun^" and is(second(args(second(ex)))=-1) then return([first(ex)/first(args(second(ex)))]),
+ ex
+)$
+
+/* We have a special case x*1/s which we need to filter out at this stage. */
+stackunits_make_recip(ex) := block([ex1,ex2],
+ if not(safe_op(ex)="/") then
+ return(ex),
+ ex1:first(args(ex)),
+ ex2:second(args(ex)),
+ if not(safe_op(ex1)="*") then
+ return(ex),
+ ex1:reverse(args(ex1)),
+ if not(is_simp((first(ex1)=1)))
+ then return(ex),
+ if is(length(ex1)=2) then
+ return(second(ex1)/ex2),
+ reverse(rest(ex1))/ex2
+)$
+
+/* Add utility functions to get units and numerical parts. */
+stack_units_units(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(second(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(second(args(su))),
+ return(ex)
+)$
+
+stack_units_nums(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(first(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(first(args(su))),
+ return(ex)
+)$
+
+stack_units_err(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if not(is(safe_op(ex) = "stackunits")) then
+ return(0),
+ if is_simp(length(args(ex))=3) then
+ return(third(args(ex))),
+ return(0)
+)$
+
+stack_units_errp(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if length(args(ex))=3 then
+ return(true),
+ return(false)
+)$
+
+/* Validate an expression which is expected to have units. */
+stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:false, exs, SAU, SBU],
+ /* Check the display option. */
+ if not(fracdisp = "inline" or fracdisp = "negpow") then block(
+ error("stack_validate_units: fracdisp argument must be either inline or negpow only.")
+ ),
+ /* Try to simply the expression to catch CAS errors. */
+ exs:errcatch(ev(expr, simp)),
+ if is_simp(exs = []) then return(false),
+ if length(expr)#1 then
+ print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr:first(expr),
+ /* Declare all symobols as "units", and change their TeX display. */
+ stack_unit_si_declare(false),
+
+ /* An empty answer is validated as valid! */
+ if (expr = EMPTYANSWER) then return(expr),
+
+ /* Do not check for floats. They are always ok here. */
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and not(all_lowest_termsex(expr)) then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* SA should be only an expression. */
+ if not(expressionp(expr) or is(safe_op(expr)=STACKpmOPT)) then
+ (print(StackAddFeedback("", "ATUnits_SA_not_expression")), return(expr)),
+
+ /* Check if the student has correctly used units.*/
+ SAU:stackunits_make(expr),
+ SBU:stackunits_make(TAns),
+ if (debug) then (print("stack_validate_units working with: "), print(SAU), print(SBU)),
+
+ /* Deal with the display of floats. */
+ /* Only use the number template when we have exactly 1 float in the expression. */
+ stackfltfmt:"~a",
+ if numberp(stack_units_nums(SAU)) or is(safe_op(stack_units_nums(SAU)) = "-") then
+ stackfltfmt:fltfmt
+ else if is(safe_op(stack_units_nums(SAU)) = "*") then
+ if is(length(sublist(args(stack_units_nums(SAU)), numberp)) <= 1) then
+ stackfltfmt:fltfmt,
+
+ /* Check if stackunits_make appears to have done something sensible. */
+ /* Student types only units. This should always be invalid. */
+ if is_simp(stack_units_nums(SAU) = NULLNUM) then
+ print(StackAddFeedback("", "ATUnits_SA_only_units"))
+ else if not(emptyp(listofvars(stack_units_nums((SAU))))) then
+ print(StackAddFeedback("", "ATUnits_SA_bad_units"))
+ else block(
+ /* Student should use units if and only if the teacher uses units. */
+ if is_simp(stack_units_units(SAU) = NULLUNITS) and not(is_simp(stack_units_units(SBU) = NULLUNITS)) then
+ print(StackAddFeedback("", "ATUnits_SA_no_units")),
+ if not(is_simp(stack_units_units(SAU) = NULLUNITS)) and is_simp(stack_units_units(SBU) = NULLUNITS) then
+ print(StackAddFeedback("", "ATUnits_SA_excess_units"))
+ ),
+
+ /* Check if the student has added in error bounds. */
+ if stack_units_errp(SAU) then
+ print(StackAddFeedback("", "ATUnits_SA_errorbounds_invalid")),
+
+ /* Add in an option to control the display of the units. */
+ expr:SAU,
+ if (debug) then (print("stack_validate_units has: "), print(expr)),
+ if fracdisp = "inline" then
+ (
+ stack_disp_fractions("i"),
+ if stack_units_errp(SAU) then
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp), ev(stack_units_err(SAU),simp))
+ else
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp))
+ ),
+ if (debug) then (print(expr)),
+ expr:detexcolor(expr),
+ return(expr)
+)$
+
+/* Finer control over display of units, separating out the number from the units. */
+stackunitstex(ex) := block ([a, b, c, astr],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ astr:tex1(a),
+ if not(atom(a)) and safe_op(a)="+" and not(is(b=NULLUNITS)) then
+ astr:sconcat("\\left( ", astr, "\\right)"),
+ if length(args(ex))=3 then
+ astr:sconcat(astr, "\\pm ", third(args(ex))),
+ /* Fine tune the edge cases. */
+ if is(safe_op(b)="/") then
+ if (is(first(args(b))=1)) then return(sconcat(astr,"\\times ",tex1(b))),
+ /* Otherwise.... */
+ sconcat(astr,"\\, ",tex1(b))
+)$
+texput(stackunits, stackunitstex);
+texput(NULLUNITS, "");
+texput(NULLNUM, "");
+
+/* Units answer tests. */
+ATUnits(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsStrict(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsStrictSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Relative")$
+ATUnitsStrictRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Relative")$
+ATUnitsAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Absolute")$
+ATUnitsStrictAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Absolute")$
+
+/* This function has two options:
+ boolean: strictp determines if the test should be "strict" in requiging exactly the correct units.
+ numtest: string Chooses the numerical test applied to the numerical part.
+*/
+ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
+ SAU, SBU, SOU, SAU1, SBU1, SOU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ if (is(_EC(errcatch(SAA:ev(SA, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ if (is(_EC(errcatch(SBB:ev(SB, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ if (is(_EC(errcatch(SOO:ev(SO, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+
+ /* SA should be only an expression. */
+ if not(expressionp(SA)) then
+ return([false, false, StackAddNote("", "ATUnits_SA_not_expression"), StackAddFeedback("", "ATUnits_SA_not_expression")]),
+
+ /* SB should be only an expression. */
+ if not(expressionp(SB)) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATUnits_TA_not_expression"), StackAddFeedback("", "TEST_FAILED_Q")])),
+
+ /* SA must have some units. */
+ if simp_numberp(SA) then
+ return([false, false, StackAddNote("", "ATUnits_SA_no_units"), StackAddFeedback("", "ATUnits_SA_no_units")]),
+
+ /* Load and setup units. */
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+
+ if (debug) then (print("ATUnitsFun: raw input: "), print(SA), print(SB)),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(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)
+ 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)
+ 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/2020052700/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2020052700/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000..d4e798f
--- /dev/null
+++ b/stack/2020052700/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"<mspace/><fnm> %and </fnm><mspace/>" wxxmlsym)
+(defprop %and "<fnm> %and </fnm>" 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 "<mspace/><fnm> %or </fnm><mspace/>" wxxmlsym)
+(defprop %or "<fnm> %or </fnm>" 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/2020052700/maxima/unittests_load.mac b/stack/2020052700/maxima/unittests_load.mac
new file mode 100644
index 0000000..072158a
--- /dev/null
+++ b/stack/2020052700/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)$
+
+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/2020052700/maxima/utils.mac b/stack/2020052700/maxima/utils.mac
new file mode 100644
index 0000000..ea52d53
--- /dev/null
+++ b/stack/2020052700/maxima/utils.mac
@@ -0,0 +1,229 @@
+/* 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(string_to_escape) := block([tmp],
+ tmp: ssubst("&", "&", string_to_escape),
+ tmp: ssubst("'", "'", tmp), /* ' is for XHTML, we need to still deal with HTML. */
+ tmp: ssubst(""", "\"", tmp),
+ tmp: ssubst(">", ">", tmp),
+ tmp: ssubst("<", "<", tmp),
+ return(tmp)
+)$
+
+/* Same for generating ECMAScript strings. */
+str_to_js(string_to_escape) := block([tmp,lines],
+ tmp: ssubst("\\\\", "\\", string_to_escape),
+ tmp: ssubst("\\\"", "\"", tmp),
+ tmp: ssubst("\\'", "'", tmp),
+ tmp: ssubst("\\b", ascii(8), tmp),
+ tmp: ssubst("\\t", ascii(9), tmp),
+ tmp: ssubst("\\n", ascii(10), tmp),
+ tmp: ssubst("\\v", ascii(11), tmp),
+ tmp: ssubst("\\r", ascii(13), tmp), /* \b\t\v\r might as well set to "" but maybe someone uses them to do magic. */
+ return(tmp)
+)$
+
+/* 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 (
+ 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 (
+ 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", "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",
+ "errcatch", "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", "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"
+}$
+
+/* 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)
+)$
diff --git a/stack/2020061000/maxima/assessment.mac b/stack/2020061000/maxima/assessment.mac
new file mode 100644
index 0000000..63cc178
--- /dev/null
+++ b/stack/2020061000/maxima/assessment.mac
@@ -0,0 +1,2359 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/****************************************************************/
+/* An assessment package for Maxima */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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 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)
+)$
+
+/* 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. */
+count_occurances(ex, v):=block(
+ if ex=v then return(1),
+ if atom(ex) then return(0),
+ apply("+", map(lambda([ex2], count_occurances(ex2, v)), 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 ret:apply("and", maplist(p, l)) else ret:"fail"$
+
+/* any_listp(p,l) true if all elements of l satisfy p. */
+any_listp(p, l) := if listp(l) then ret:apply("or", maplist(p, l)) else ret:"fail"$
+
+/* 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)))$
+
+/* 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!
+*/
+exdowncase(ex) := block([lv],
+ lv:listofvars(ex),
+ lv:map(lambda([v], v=parse_string(sdowncase(string(v)))),lv),
+ return(subst(lv,ex)))$
+
+/* 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")$
+
+
+/* ********************************** */
+/* Type predicates */
+/* ********************************** */
+
+/* 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)
+)$
+
+/* 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_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)="/" 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,
+ ex:errcatch(ev(fullratsimp(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)
+)$
+
+/* 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
+ 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)
+)$
+
+/* 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)) 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,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)))
+)$
+
+
+/* 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],
+ [n, dp]:args(ex),
+ ss:sconcat("~,", string(dp), "f"),
+ if is(equal(dp,0)) then ss:"~d",
+ ev(printf(false, ss, ev(float(n))), simp)
+);
+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(make_displaydpvalue, args(ex)))),
+ return(first(args(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) := 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],
+ [n, dp, expo]:args(ex),
+ ss:sconcat("~,", string(dp), "f \\times 10^{~a}"),
+ if is(equal(dp, 0)) then ss:"~d \\times 10^{~a}",
+ ev(printf(false, ss, ev(float(n)), expo), simp)
+)$
+texput(displaysci, displayscitex)$
+
+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)))
+)$
+
+/* ********************************** */
+/* 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, ex, vi],
+ /* 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,
+ /* 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. */
+ SA:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SA),
+ SB:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SB),
+ if not(freeof(displaydp, SA)) then
+ SA:remove_displaydp(SA),
+ if not(freeof(displaydp, SB)) then
+ SA:remove_displaydp(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),
+ 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),
+ 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, stack_mtell_quiet],
+ stack_mtell_quiet:true,
+ /* 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. */
+ pvars:listofvars([p1,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(ev(p1-p2, lv, simp)),
+ if debug then print(lv, pval),
+ /* 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. (p1)"), return(false)),
+ pval:errcatch(ev(is(abs(first(pval)) > 1/10000), simp)),
+ if is(pval = []) then (print("STACK: ignore previous error. (p1)"), 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))),
+ /* Now we evaluate the difference of the expressions at each variable. */
+ p1:errcatch(ev(float(p1), lv, numer_pbranch:true, simp)),
+ if is(p1 = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ p2:errcatch(ev(float(p2), lv, numer_pbranch:true, simp)),
+ if is(p2 = []) then (print("STACK: ignore previous error. (p2)"), 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)),
+ /* print([p1,p2,sz]), */
+ if is(sz = []) then (print("STACK: ignore previous error."), return(false)),
+ if first(sz) > 0.0001 then true else 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(ex1,ex2):=block([lv1, lv2, lvi, lvp, lvs, lve, il, perm_size, simp],
+ 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:listify(setdifference(lv1, get_ops(ex1))),
+ lv2:listify(setdifference(lv2, get_ops(ex2))),
+ if length(lv1)#length(lv2) then return([]),
+ /* 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 (
+ lv1:setify(lv1),
+ lv2:setify(lv2),
+ lvi:intersection(lv1, lv2),
+ lv1:listify(setdifference(lv1, lvi)),
+ lv2:listify(setdifference(lv2, lvi))
+ ),
+ if length(lv1)>perm_size then return(false),
+ /* */
+ lvp:listify(permutations(lv2)),
+ /* Create a list of subsitutions */
+ lvs:map(lambda([ex], zip_with("=", lv1, ex)), lvp),
+ /* 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)))
+)$
+
+/* ********************************** */
+/* Noun arithmetic */
+/* ********************************** */
+
+/* ** Noun forms of the arithmetic functions ** */
+
+/* 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.
+*/
+
+/* Create noun forms of the functions of +, -, *, / and ^
+ as follows.
+ + noun+
+ - noun-
+ * noun*
+ / noun/
+ ^ noun^
+*/
+
+/* 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("noun=", 150);
+nary("noun+", 100);
+prefix("noun-", 100);
+nary("noun*", 120);
+infix("noun/", 122, 123);
+infix("noun^", 140, 139);
+prefix("UNARY_RECIP", 100);
+
+declare("noun*", commutative);
+declare("noun+", commutative);
+
+/* (2) */
+load("noun_arith.lisp");
+
+/* (3) */
+declare("noun=", commutative);
+declare("noun=", lassociative);
+declare("noun=", rassociative);
+
+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
+)$
+
+verb_arith(ex) := block([a],
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:subst("/", "noun/", ex),
+ ex:subst("^", "noun^", ex),
+ define(UNARY_RECIP a, a^(-1)),
+ ex:ev(ex, UNARY_MINUS=-1),
+ remfunction("noun+", "noun*", "noun/", "noun^", "noun-", "UNARY_RECIP"),
+ ex
+)$
+
+/* (4) */
+noun_arith(ex) := block([a],
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex),
+ /* Unary minus really communtes with multiplication. */
+ ex:subst(lambda([ex], UNARY_MINUS noun* ex), "-", ex),
+ /* Turn 1/x into x^(-1), in a special form */
+ ex:subst(lambda([ex1, ex2], ex1 noun* (UNARY_RECIP ex2)), "/", ex),
+ define(UNARY_RECIP a, a noun^ (-1)),
+ ex:ev(subst("noun^", "^", ex)),
+ remfunction("UNARY_RECIP"),
+ ev(ex)
+)$
+
+/* (5) Assumes we are working in the context of noun operators. */
+gather_reduce(ex) := block(
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:ev(flatten(ex), simp),
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex), --
+ ex:subst("noun-", "-", 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)="noun+" or op(ex)="noun*" 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)="noun=" or safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="nounnot" or safe_op(ex)="nounset" or op(ex)="noun+" or op(ex)="noun*" 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)="noun^") then return(ex),
+ if not(second(args(ex))=-1) then return(ex),
+ if safe_op(first(args(ex)))="noun^" and integerp(second(args(first(args(ex))))) then return("noun^"(first(args(first(args(ex)))),-second(args(first(args(ex)))))),
+ ex
+);
+
+/* Recursive rule which takes UNARY_MINUS noun* n, where n is an integer to -n */
+unary_minus_remove(ex):= block(
+ if atom(ex) then return(ex),
+ if safe_op(ex)="noun*" and is(first(args(ex))=UNARY_MINUS) and integerp(second(args(ex))) then return(-second(args(ex))),
+ apply(op(ex), maplist(unary_minus_remove, args(ex)))
+);
+
+/* (7) */
+/* 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:subst(nounset,set,ex1),
+ ex2n:subst(nounset,set,ex2),
+ ex1n:noun_arith(ex1n),
+ ex2n:noun_arith(ex2n),
+ ex1n:flatten_recurse_nouns(ex1n),
+ ex2n:flatten_recurse_nouns(ex2n),
+ ex1n:sort_nouns(ex1n),
+ ex2n:sort_nouns(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"), ""]),
+
+ sa:remove_stackeq(sa),
+ sb:remove_stackeq(sb),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(sa,sb),
+ 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(sa, sb)),
+ 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(sa, sb) 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)$
+
+/****************************************************************/
+/* Define noun versions of logical "and" and "or". */
+/****************************************************************/
+
+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 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(integrate), 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);
+
+/* 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 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)
+)$
+
+/****************************/
+/* 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\\mbox{(?)}}");
+/* Here we add tags. These are for localisation. Dealt with on the PHP side in cassession -> instantiate. */
+texput(SAMEROOTS, "\\color{green}{\\mbox{!SAMEROOTS!}}");
+texput(ANDOR, "\\color{red}{\\mbox{!ANDOR!}}");
+texput(MISSINGVAR, "\\color{red}{\\mbox{!MISSINGVAR!}}");
+texput(ASSUMEPOSVARS, "\\color{blue}{\\mbox{!ASSUMEPOSVARS!}}");
+texput(ASSUMEREALVARS, "\\color{blue}{(\\mathbb{R})}");
+texput(ASSUMEPOSREALVARS, "\\color{blue}{\\mbox{!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("\\mbox{!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_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 ", FAA, " and ", FAB),
+ 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(
+ ATres:ev(ATAlgEquiv(SA, first(FBB)), simp),
+ if (debug) then print(ATres),
+ if second(ATres) then block(
+ 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(single_variable_solver_real(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.*/
+ note: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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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/2020061000/maxima/assessment.texi b/stack/2020061000/maxima/assessment.texi
new file mode 100644
index 0000000..8e3b16f
--- /dev/null
+++ b/stack/2020061000/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} noun+ (@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} noun* (@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} noun^ (@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} noun- (@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 noun* 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 noun* ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 noun* (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<x,x<4])
+ (%i3) to_poly_solve(abs(x)<2,x);
+ (%o3) %union([-2<x,x<2])
+ @end example
+ These need to be incorporated, expanded and developed.
+@item A test which finds a mapping of variable names which makes two expressions equal (or returns ``false''). Also known as unification.
+@item Tests which deal with scientific units.
+@item Step-by-step derivation of standard types of problems.
+@item A larger range of buggy rules.
+@end enumerate
+
+@bye
+
+@chapter References
+
+@itemize @asis
+
+@mybibitem{Sangwin2010IGI}
+M. Badger and C.J. Sangwin. My equations are the same as yours!: computer aided assessment using a Grobner basis approach.
+In A. A. Juan, M. A. Huertas, and C. Steegmann, editors, Teaching Mathematics Online: Emergent Technologies and Methodologies. IGI Global, 2011.
+
+@end itemize
+
+@bye
+
+@mybibitem{Sangwin2009CalculumusII}
+R. Bradford, J. H. Davenport, and C. J. Sangwin. A comparison of equality in computer algebra and correctness in mathematical pedagogy. The International Journal for Technology in Mathematics Education, 2010.
+
+@mybibitem{Caviness1970}
+B. F. Caviness. On canonical forms and simplification. Journal of the ACM (JACM), 17(2):385-396, 1970.
+
+@mybibitem{CervalPena2008}
+E. R. Cerval-Pena. Automated computer-aided formative assessment with ordinary differential equations. Master's thesis, University of Birmingham, 2008.
+
+@mybibitem{Fenichel1966}
+R. R. Fenichel. An On-line System for Algebraic Manipulation. Phd thesis, Harvard Graduate School of Arts and Sciences, 1966.
+
+@mybibitem{Harjula2008}
+M. Harjula. Mathematics exercise system with automatic assessment. Master's thesis, Helsinki University of Technology, 2008.
+
+@mybibitem{Jenks1992}
+R. D. Jenks and R. S. Sutor. AXIOM: the scientific computation system. The Numerical Algorithms Group Ltd, 1992. ISBN: 0-387-07855-0.
+
+@mybibitem{Lowe2010}
+T. Lowe. e-Assessment using Symbolic Manipulation Tools. Technical report, Centre for Open Learning of Mathematics, Science, Computing and Technology, The Open University, 2010.
+
+@mybibitem{Moses1971}
+J. Moses. Algebraic simplification a guide for the perplexed. Communications of the ACM, 14(8):527-537, August 1971.
+
+@mybibitem{Nakamura2010}
+Y. Nakamura. The STACK e-Learning and Assessment System for mathematics, science and engineering education through Moodle, chapter Preface, pages vi-vii.
+Tokyo Denki University Press, 2010. In Japanese. ISBN 978-4-501-54820-9.
+
+@mybibitem{Rasila2007}
+A. Rasila, M. Harjula, and K. Zenger.
+Automatic assessment of mathematics exercises: Experiences and future prospects.
+In ReflekTori 2007: Symposium of Engineering Education, pages 70-80. Helsinki University of Technology, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2007.
+
+@mybibitem{Rasila2010}
+A. Rasila, L. Havola, Majander H., and J. Malinen. Automatic assessment in engineering mathematics: evaluation of the impact.
+In ReflekTori 2010: Symposium of Engineering Education. Aalto University, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2010.
+
+@mybibitem{Richardson1966}
+D. Richardson. Solvable and Unsolable Problems Involving Elementary Functions of a Real Variable. PhD thesis, University of Bristol, 1966.
+
+@mybibitem{Ruokokoski2009}
+J. Ruokokoski. Automatic assessment in university-level mathematics. Master's thesis, Helsinki University of Technology, 2009.
+
+@mybibitem{SangwinTMA03}
+C. J. Sangwin. Assessing mathematics automatically using computer algebra and the internet. Teaching Mathematics and its Applications, 23(1):1-14, 2004.
+
+@mybibitem{Sangwin2006CASAlgebra}
+C. J. Sangwin. Assessing Elementary Algebra with STACK.
+International Journal of Mathematical Education in Science and Technology, 38(8):987-1002, December 2008.
+
+@mybibitem{2010STACKReport}
+C. J. Sangwin. Who uses STACK? A report on the use of the STACK CAA system. Technical report, The Maths Stats and OR Network, School of Mathematics, The University of Birmingham, 2010.
+
+@mybibitem{WebALT2006}
+C. J. Sangwin and M. J. Grove.
+STACK: addressing the needs of the ``neglected learners''. In Proceedings of the First WebALT Conference and Exhibition January 5-6, Technical University of Eindhoven, Netherlands, pages 81-95. Oy WebALT Inc, University of Helsinki, ISBN 952-99666-0-1, 2006.
+
+@mybibitem{Sleeman1982}
+D. Sleeman and J. S. Brown, editors. Intelligent Tutoring Systems. Academic Press, 1982.
+
+@mybibitem{Wild2009}
+I. Wild. Moodle 1.9 Math. Packt Publishing, 2009.
+
+@end itemize
+
+@bye
+
+
+@node Function and variable index, , Definitions for MYTOPIC, Top
+@appendix Function and variable index
+@printindex fn
+@printindex vr
+
+@bye
+
+@C \documentclass[11pt]{article}
+@C \newcommand{\href}[2]{#2}
+@C \begin{document}
+@C \bibliographystyle{plain}
+@C
+@C \cite{Jenks1992,Richardson1966,Caviness1970,Moses1971}\cite{Fenichel1966,Sleeman1982}\cite{Sangwin2010IGI,Sangwin2009CalculumusII}\cite{Sangwin2006CASAlgebra, WebALT2006,SangwinTMA03} \cite{CervalPena2008,Wild2009,Lowe2010,2010STACKReport}\cite{Rasila2007,Rasila2010,Ruokokoski2009,Harjula2008,Nakamura2010}.
+@C
+@C \bibliography{/Bib/education,/Bib/sangwin,/Bib/PUS,/Bib/MathsTexts,/Bib/CAA,/Bib/sr,/Bib/students}
+@C
+@C \end{document}
+
+@c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+@deffn {Function} expressionp (@var{ex})
+@end deffn
\ No newline at end of file
diff --git a/stack/2020061000/maxima/casanswertest.mac b/stack/2020061000/maxima/casanswertest.mac
new file mode 100644
index 0000000..b28d0f6
--- /dev/null
+++ b/stack/2020061000/maxima/casanswertest.mac
@@ -0,0 +1,254 @@
+/* This file contains functions used to wrap previously PHP side portions of
+ answertest processing over the existing CAS side logic to allow those tests
+ to be executed fully on CAS side. Some of this logic relies on the raw string
+ values of student inputs being available. */
+
+
+/* These are essentially the old atnumsigfigs.class.php with some validation happening outside this. */
+ATNumSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans) := block([allowextra,requiredsigfigs,requiredaccuracy,digits,result,Validity,RawMark,FeedBack,AnswerNote],
+ /* The return value */
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* First unpack the options. */
+ /* Note, in this test we first define the required number of significant digits,
+ no more no less, we may also define a second parameter that provides three
+ ways of function.
+
+ First for positive values, it defines the number of those significant digits
+ that need to match the correct ones. Makes no sense for this to be bigger than
+ the number of required digits.
+
+ Second for zero value it means that we do not care about the value only of the
+ form i.e. you can input any digits you want as long as they can be interpreted
+ as the correct number of significant digits.
+
+ Third for the special value of -1 it defines that we allow more significant
+ digits than what we require and that the value must match for those we require.
+ */
+ requiredsigfigs: 3,
+ requiredaccuracy: -1,
+ allowextra: false,
+
+ if listp(options) then (
+ requiredsigfigs: options[1],
+ requiredaccuracy: options[2]
+ ) else (
+ requiredsigfigs: options,
+ requiredaccuracy: options
+ ),
+
+ if ev(is(requiredaccuracy = -1),simp) then (
+ allowextra: true,
+ requiredaccuracy: requiredsigfigs
+ ),
+
+ /* What if the options do not make sense? */
+ /* Note that the options may now be dynamic and evaluated in CAS. */
+ if requiredsigfigs <= 0 or requiredaccuracy < 0 or not integerp(requiredsigfigs) or not integerp(requiredaccuracy) then (
+ return([false, false, "STACKERROR_OPTION.", ""])
+ ),
+
+ /* Find the number of digits. */
+ digits: sig_figs_from_str(rawsans),
+
+ if allowextra = true then (
+ if requiredsigfigs > 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 (
+ result: ATNumSigFigs(sans,tans,requiredaccuracy),
+ Validity: Validity and result[1],
+ RawMark: RawMark and result[2],
+ if result[3] # "" then (
+ AnswerNote: sconcat(AnswerNote, result[3])
+ ),
+ if result[4] # "" then (
+ FeedBack: sconcat(FeedBack, result[4])
+ )
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+
+ATSigFigsStrict_CASSigFigsWrapper(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])
+)$
+
+ATUnitsSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans,strict) := block([tmp1, tmp2],
+ /* First the units and value */
+ tmp1: ATUnitsFun(sans, tans, options, strict, "SigFigs"),
+
+ /* If we do not have valid stuff for units tests we better drop out now. */
+ if is(tmp1[1] = false) then return(tmp1),
+
+ /* Then check the figures */
+ tmp2: ATNumSigFigs_CASSigFigsWrapper(
+ float(stack_units_nums(stack_unit_si_to_si_base(sans))),
+ float(stack_units_nums(stack_unit_si_to_si_base(tans))),options,rawsans),
+
+ /* Merge*/
+ return([tmp1[1] and tmp2[1], tmp1[2] and tmp2[2], sconcat(tmp1[3],tmp2[3]), sconcat(tmp1[4],tmp2[4])])
+)$
+
+ATNumDecPlaces_CASDecPlacesWrapper(sans,tans,options,rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote,required,val],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ RawMark: false,
+ Validity: false
+ ),
+
+ if Validity then (
+ /* 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])
+)$
+
+
+ATDecimalPlacesWrong(sans,tans,options) := block([Validity,RawMark,FeedBack,AnswerNote,_sans,_tans,required],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_displaydp(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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ 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_displaydp(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/2020061000/maxima/elementary.mac b/stack/2020061000/maxima/elementary.mac
new file mode 100644
index 0000000..4a97fa2
--- /dev/null
+++ b/stack/2020061000/maxima/elementary.mac
@@ -0,0 +1,521 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+
+/* 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 */
+
+/* http://www.ncl.ac.uk/math/numbas/manual.pdf and
+https://github.com/numbas/Numbas/blob/master/runtime/scripts/jme-display.js#L749
+
+ unitDenominator transform x/1 to x
+ zeroPower transform x^0 to 1
+ simplifyFractions transform (a*b)/(a*c) to b/c
+ zeroBase transform 0^x to 0
+ sqrtProduct simplify sqrt(a)*sqrt(b) to sqrt(a*b)
+ sqrtDivision simplify sqrt(a)/sqrt(b) to sqrt(a/b)
+ sqrtSquare simplify sqrt(x^2) to x
+ trig simplify various trigonometric values e.g. sin(n*pi) to 0
+ otherNumbers simplify 2^3 to 8
+ fractionNumbers display all numbers as fractions instead of decimals
+*/
+
+/* NOTE: all these operations really need three separate
+things, as with zeroAdd:
+
+zeroAddp - the predicate which matches to the pattern zeroAdd -
+perform the rule on the top level. zeroAddr - recurse over the
+whole expression applying the rule.
+
+What about working through to the first occurance of the
+pattern?
+
+What about identifying the first occurance of where a rule is
+satisfied?
+
+*/
+
+/*******************************************/
+/* Control functions */
+/*******************************************/
+
+/* List of all available rules */
+ID_TRANS:["zeroAdd","zeroMul","oneMul","onePow","idPow","zeroPow","zPow"]$
+ALG_TRANS:["assAdd","assMul","unaryAdd","unaryMul","comAdd","comMul"]$
+NEG_TRANS:["negZero","negDef","negNeg","negInt","negMinusOne","negDistAdd","negProdA","negProdB"]$
+INT_ARITH:["intAdd","intMul","intPow"]$
+DIV_TRANS:["oneDiv","idDiv","divDivA","divDivB","recipDef","recipNeg","recipMul"]$
+DIS_TRANS:["disAddMul"]$
+POW_TRANS:["powLaw"]$
+ALL_TRANS:append(ALG_TRANS,ID_TRANS,INT_ARITH,NEG_TRANS,DIV_TRANS,DIS_TRANS,POW_TRANS)$
+
+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)))$
+
+
+/* Transform recursively accross an expression*/
+transr(ex,rl):=block(
+ if atom(ex) then return(ex),
+ if listp(rl) then error("transr: only apply one rule using transr"),
+ if trans_topp(ex,rl) then
+ /* If applying the rule changes the expression then do so */
+ block([ex2], ex2:apply(parse_string(rl),[ex]), if ex=ex2 then ex else transr(ex2,rl) )
+ else return(map(lambda([ex2],transr(ex2,rl)),ex))
+)$
+
+/* Apply a list of rules recursively, in order, once each */
+transl(ex,rll):=block(
+ if atom(ex) or not(listp(rll)) or emptyp(rll) then return(ex),
+ return(transl(transr(ex,first(rll)),rest(rll)))
+)$
+
+/*******************************************/
+/* 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)))
+)$
+
+
+/*******************************************/
+/* Transformation rules */
+/*******************************************/
+
+/* 0+x -> x */ /* Strictly zero at the first part */
+zeroAddp(ex):= block(
+ if safe_op(ex)="+" and is(part(ex,1)=0) then true else false
+)$
+
+zeroAdd(ex) := block(
+ if zeroAddp(ex) then
+ return( block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("+",rest(args(ex)))))),
+ return(ex)
+)$
+
+/* zeroMul transform 0*x to 0 */
+zeroMulp(ex) := block(
+ if safe_op(ex)="*" and is(part(ex,1)=0) then true else false
+)$
+
+zeroMul(ex) := block(
+ if zeroMulp(ex) then return(0) else return (ex)
+)$
+
+/* oneMul transform 1*x to x */
+oneMulp(ex) := block([ex2],
+ if safe_op(ex)="*" and is(part(ex,1)=1) then true else false
+)$
+
+oneMul(ex) := block([ex2],
+ if oneMulp(ex) then
+ return(block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("*",rest(args(ex))))))
+ else return(ex)
+)$
+
+/* 1^x -> 1 */
+onePowp(ex):=block(
+ if safe_op(ex)="^" and is(part(ex,1)=1) then true else false
+)$
+
+onePow(ex):= if onePowp(ex) then 1 else ex$
+
+/* x^1 -> x */
+idPowp(ex):=block(
+ if safe_op(ex)="^" 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 safe_op(ex)#"^" 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 safe_op(ex)#"^" 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$
+
+/* "+"(x) -> x. (Probably not needed, but we may end up with sums of lists of length 1.)*/
+unaryAddp(ex):= block(
+ if safe_op(ex)="+" and length(args(ex))=1 then true else false
+)$
+
+unaryAdd(ex):= if unaryAddp(ex) then first(args(ex)) else ex$
+
+/* "*"(x) -> x. (Probably not needed.)*/
+unaryMulp(ex):= block(
+ if safe_op(ex)="*" and length(args(ex))=1 then true else false
+)$
+
+unaryMul(ex):= if unaryMulp(ex) then first(args(ex)) 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)="+" and flatten(ex)#ex then true else false$
+assAdd(ex) := if assAddp(ex) then flatten(ex) else ex$
+
+assMulp(ex):= if safe_op(ex)="*" and flatten(ex)#ex then true else false$
+assMul(ex) := if assMulp(ex) then flatten(ex) else ex$
+
+/* Define a predicate to sort elements, NEG at the front, RECIP at the end. */
+orderelementaryp(exa,exb):=block(
+ if exa=NEG then return(true),
+ if exb=NEG then return(false),
+ if safe_op(exa)="RECIP" and safe_op(exb)="RECIP" then return(orderlessp(part(exa,1),part(exb,1))),
+ if safe_op(exa)="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)#"RECIP")),
+ l2:sublist(l, lambda([ex],not(atom(ex)) and safe_op(ex)="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)="+" and apply("+",elsort(args(ex)))#ex then true else false$
+comAdd(ex) := if comAddp(ex) then apply("+",elsort(args(ex))) else ex$
+
+comMulp(ex):= if safe_op(ex)="*" and apply("*",elsort(args(ex)))#ex then true else false$
+comMul(ex) := if comMulp(ex) then apply("*",elsort(args(ex))) else ex$
+
+/*******************************************/
+/* Double negation -(-(a)) */
+negNegp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if safe_op(part(ex,1))="-" then return(true) else return(false)
+)$
+
+negNeg(ex):=if negNegp(ex) then part(ex,1,1) else ex$
+
+/* -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))
+)$
+
+/* Negation of zero -0 -> 0 */
+negZerop(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if is(part(ex,1)=0) then return(true) else return(false)
+)$
+
+negZero(ex):=if negZerop(ex) then 0 else ex$
+
+/* Turns the negation of an integer into an actual integer "-"(n) -> -n */
+negIntp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if integerp(part(ex,1)) then return(true) else return(false)
+)$
+
+negInt(ex):=if negIntp(ex) then ev(ex,simp) else ex$
+
+/* Turns unary minus in a product into a special symbol NEG */
+negProdAp(ex):=block(
+ if safe_op(ex)#"*" then return(false),
+ return(any_listp(lambda([ex],if safe_op(ex)="-" then true else false),args(ex)))
+)$
+
+negProdA(ex):=block(
+ if negProdAp(ex)=false then return(ex),
+ apply("*",maplist(lambda([ex],if safe_op(ex)="-" then NEG*first(args(ex)) else ex),args(ex)))
+)$
+
+/* matches up to NEG*... and turns this back into unary minus... */
+negProdBp(ex):=if safe_op(ex)="*" and first(args(ex))=NEG then true else false$
+
+negProdB(ex):=block(
+ if negProdBp(ex)=false then return(ex),
+ -apply("*",rest(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)
+)$
+
+
+/* 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)))
+)$
+
+/* 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)
+)$
+
+/* 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
+)$
+
+/*******************************************/
+/* Warning, this is not safe on non-atoms, it evaluates them! */
+notintegerp(ex):= if atom(ex) then not(integerp(ex)) else true$
+
+/* Evaluate integer arithmetic */
+intAddp(ex):=block(
+ if safe_op(ex)#"+" then return(false),
+ if length(sublist(args(ex), integerp))>1 then return(true) else return(false)
+)$
+
+intAdd(ex):=block([a1,a2],
+ if intAddp(ex)=false then return(ex),
+ a1:sublist(args(ex), integerp),
+ a1:ev(apply("+",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1+first(a2)
+ else a1+apply("+",a2)
+)$
+
+intMulp(ex):=block(
+ if safe_op(ex)#"*" 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), integerp),
+ a1:ev(apply("*",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1*first(a2)
+ else apply("*",append([a1],a2))
+)$
+
+intPowp(ex):=block(
+ if safe_op(ex)#"^" 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)
+)$
+
+/*******************************************/
+/* Division rules */
+
+/* a/1 -> a */
+oneDivp(ex):= if safe_op(ex)="/" and part(ex,2)=1 then true else false$
+oneDiv(ex) := if oneDivp(ex) then part(ex,1) else ex$
+
+/* 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$
+
+/* a/(b/c)-> a*(c/b) */
+divDivAp(ex) := if safe_op(ex)="/" and safe_op(part(ex,2))="/" then true else false$
+divDivA(ex) := if divDivAp(ex) then part(ex,1)*(part(ex,2,2)/part(ex,2,1)) else ex$
+
+/* (a/b)/c-> a/(c*b) */
+divDivBp(ex) := if safe_op(ex)="/" and safe_op(part(ex,1))="/" then true else false$
+divDivB(ex) := if divDivBp(ex) then part(ex,1,1)/(part(ex,1,2)*part(ex,2)) else ex$
+
+/*******************************************/
+/* RECIP */
+
+/* re-write a/b as RECIP */
+
+recipDefp(ex) := if safe_op(ex)="/" then true else false$
+recipDef(ex) := if recipDefp(ex) then part(ex,1)*RECIP(part(ex,2))$
+
+/* RECIP(-x) -> -RECIP(x) */
+recipNegp(ex) := if safe_op(ex)="RECIP" and safe_op(part(ex,1))="-" then true else false$
+recipNeg(ex) := if recipNegp(ex) then -RECIP(part(ex,1,1)) else ex$
+
+/* a*RECP(b)*RECIP(c) -> a*RECIP(b*c) */
+recipMulp(ex) := block([l],
+ if safe_op(ex)#"*" then return(false),
+ if length(args(ex))=1 then return(false),
+ l:reverse(args(ex)),
+ if safe_op(first(l))="RECIP" and safe_op(second(l))="RECIP" then true else false
+)$
+
+recipMul(ex) := block([p1,p2],
+ if recipMulp(ex)#true then return(ex),
+ l:reverse(args(ex)),
+ apply("*",append(reverse(rest(rest(l))),[RECIP(part(second(l),1)*part(first(l),1))]))
+)$
+
+/*******************************************/
+/* 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)
+);
+
+/*******************************************/
+/* Buggy rules */
+
+/* (a+b)^n -> a^n+b^n */
+buggyPowp(ex):=block(
+ if safe_op(ex)#"^" then return(false),
+ if safe_op(part(ex,1))="+" then true else false
+)$
+
+buggyPow(ex):= if buggyPowp(ex) then apply("+",map(lambda([ex2],ex2^part(ex,2)),args(part(ex,1)))) else ex$
+
+/* -(a+b) -> -a+b */
+buggyNegDistAddp(ex) := negDistAddp(ex)$
+buggyNegDistAdd(ex) := if buggyNegDistAddp(ex) then apply("+",append([-first(args(part(ex,1)))],rest(args(part((ex),1))))) else ex$
+
+
+/*******************************************/
+/* Testing */
+simp:false;
+/*STT:batch("rtest_elementary.mac", test);*/
+simp:false;
+
+
+
diff --git a/stack/2020061000/maxima/errortostring.lisp b/stack/2020061000/maxima/errortostring.lisp
new file mode 100644
index 0000000..df6ba14
--- /dev/null
+++ b/stack/2020061000/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/2020061000/maxima/expandfeedback.mac b/stack/2020061000/maxima/expandfeedback.mac
new file mode 100644
index 0000000..8d688ae
--- /dev/null
+++ b/stack/2020061000/maxima/expandfeedback.mac
@@ -0,0 +1,139 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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)$
+
+
+/* This function applies the binary function f to two lists a and b
+ returning a list [ f(a[1],b[1]), f(a[2],b[2]), ... ]
+ zip_with quietly gives up when one of the list runs out of elements. */
+zip_with(f,a,b) := block(
+ if listp(a)= false then return(false),
+ if listp(b)= false then return(false),
+ if a = [] then return([]),
+ if b = [] then return([]),
+ cons(f(first(a),first(b)),zip_with(f,rest(a),rest(b)))
+)$
+
+/* 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/2020061000/maxima/experimental.mac b/stack/2020061000/maxima/experimental.mac
new file mode 100644
index 0000000..3ee1f9e
--- /dev/null
+++ b/stack/2020061000/maxima/experimental.mac
@@ -0,0 +1,167 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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))));
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 January 2013 */
+/* */
+/****************************************************************/
+
+/* Sample ways of representing a PRT in which we might have errors */
+
+/* Evaluate a single node safely. */
+node_no(prt,num,inputs) := block([res,err],
+ /* Type checking */
+ if not(listp(prt)) then error("node_no expects its first argument to be a list."),
+ if not(integerp(num)) then error("node_no expects its second argument to be an integer."),
+ if is(length(prt)<num) then error("node_no expects its second argument to less than the length of the first."),
+ /* Do computation */
+ res:errcatch(ev(prt[num],inputs,nouns)),
+ if is([] = res) then
+ print(concat("Previous error generated by node number ", string(num), ".")),
+ if is([] = res) then
+ []
+ else
+ first(res)
+ );
+
+/* Actually traverse the PRT with given inputs */
+/* Inputs should be in the form of equations such as [ans1=x^2] */
+traverse_prt(inputs) := block(
+ /* Type checking */
+ if not(listp(inputs)) then error("traverse_prt expects its argument to be a list."),
+ if not(alllistp(equationp,inputs)) then error("traverse_prt expects its argument to be a list of equations."),
+ /* Setup PRT */
+ simp:false,
+ PRTtests:[
+ 'ATAlgEquiv(ans1,x^3),
+ 'ATInt(ans2,[x^3,x]),
+ 'ATInt(ans2/0,[x^3,x])
+ ],
+ quiet:[false,false,false],
+ nexttrue:[2,3,1],
+ nextfalse:[1,1,1],
+ /* Creatlist to store previously visited nodes */
+ visited:makelist(false, length(PRTtests)),
+ current_node:1,
+ feedback:[],
+ answernote:[],
+ /* Actually traverse the tree */
+ while not(visited[current_node]) do block([res],
+ visited[current_node]:true,
+ res:node_no(PRTtests,current_node,inputs),
+ if not(listp(res)) then return(false),
+ /* Feedback */
+ if not(quiet[current_node]) then feedback:cons(res[4], feedback),
+ feedback:cons(concat("[STACK-feedback:",string(current_node),"-",string(res[2]),"]"), feedback),
+ /* Answernotes */
+ if not(is(res[3] = "")) then answernote:cons(res[3], answernote),
+ answernote:cons(concat(string(current_node),"-",string(res[2])), answernote),
+ /* Update to next node */
+ if res[2] then
+ current_node:nexttrue[current_node]
+ else
+ current_node:nextfalse[current_node]
+ ),
+ answernote:simplode(reverse(sublist(answernote, lambda([ex],not(is(ex=""))))), " | " ),
+ feedback:simplode(reverse(sublist(feedback, lambda([ex],not(is(ex=""))))), " | " ),
+ [answernote, feedback]
+)$
+
+print("[ STACK-reports started. ]")$
+
+/****************************************************************/
+/* Unary minus functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 March 2014 */
+/* */
+/****************************************************************/
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_minus_simp(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and first(args(ex))<0 then return(ev(ex,simp)),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "-" then return(first(args(first(args(ex))))),
+ apply(op(ex), map(unary_minus_minus_simp, args(ex)) )
+)$
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_add_distrib(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "+" then return(apply("+", map(lambda([ex2],-ex2), args(first(args(ex)))))),
+ apply(op(ex), map(unary_minus_add_distrib, args(ex)) )
+)$
+
+/****************************************************************/
+/* Square root functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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/2020061000/maxima/inequalities.mac b/stack/2020061000/maxima/inequalities.mac
new file mode 100644
index 0000000..4455ae9
--- /dev/null
+++ b/stack/2020061000/maxima/inequalities.mac
@@ -0,0 +1,306 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* 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, <chris@sangwin.com> */
+/* 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],
+ 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. */
+ ev(expand(ex/abs(numerical_coeff(ex))), simp)
+)$
+
+/* 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<x or x<a: a syntactic transformation. */
+inequality_disp(ex) := block([ex2, v],
+ if not(linear_inequalityp(ex)) then return(ex),
+ ex2:ineqprepare(ex),
+ v:first(listofvars(ex2)),
+ if equal(coeff(lhs(ex2), v), 1) then return(rev_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ if equal(coeff(lhs(ex2), v), -1) then return(neg_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ return(ex)
+)$
+
+/* Reverses the inequality: purely syntactic. */
+rev_ineq(ex):=block(
+ 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)),
+ 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)<lhs(ex)),
+ if op(ex)=">=" then return(rhs(ex)<=lhs(ex)),
+ return(apply(op(ex), map(make_less_ineq, args(ex))))
+)$
+
+/* Used to checks if we have the wrong inequality. */
+neg_ineq(ex):=block(
+ 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)
+)$
+
+/* 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<?, x<=?. */
+ exg:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = 1))),
+ exl:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = -1))),
+ /* Separate into solution and operator. */
+ exg:single_linear_ineq_reduce_h(exg, first(exo), true),
+ exl:single_linear_ineq_reduce_h(exl, second(exo), false),
+ append(exg, exl)
+)$
+
+/* Take a list of linear inequalities of the same sign, in a single variable, and an operator, min/max.
+ Return the single equivalent inequality.
+*/
+single_linear_ineq_reduce_h(exl, exo, odr):=block([m1,m2,m3,exg],
+ if exl=[] then return([]),
+ if not(is(exo = max) or is(exo = min)) then error("single_linear_ineq_reduce_h expects second argument to be max or min."),
+ exg:maplist(lambda([ex2],[rhs(first(solve(lhs(ex2)))), op(ex2)]), exl),
+ m1:apply(exo, maplist(first,exg)),
+ m2:sublist(exg,lambda([ex2],is(m1=first(ex2)))),
+ /* Get list of operators. Used to sort out >, >= 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)),
+ /* 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),
+ 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/2020061000/maxima/intervals.mac b/stack/2020061000/maxima/intervals.mac
new file mode 100644
index 0000000..55ed26f
--- /dev/null
+++ b/stack/2020061000/maxima/intervals.mac
@@ -0,0 +1,929 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* A package for manipulating intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* Re-written, May 2020. Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* 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 then Ans:{}, /* Our interval is the empty set if y<x. */
+ if x=y then Ans:{x}, /* Simply the set {x} is x=y. */
+ Ans
+)$
+
+oo_num(x,y) := block([Ans],
+ Ans: 'oo(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf ), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y) and not(y=inf or y=-inf ), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+co_num(x,y) := block([Ans],
+ Ans: 'co(x,y),
+ if ev(not real_numberp(x), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev((not real_numberp(y) and not(y=inf or y=-inf)), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+oc_num(x,y) := block([Ans],
+ Ans: 'oc(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+/* Validate student's input. */
+
+/* Return a list of errors for a single connected component. */
+interval_validate_single_interval(ex) := block([ret, iop, il, ir],
+ ret:"",
+ if trivialintervalp(ex) then return(""),
+ if not(intervalp(ex)) then
+ return(StackAddFeedback("", "Interval_notinterval", stack_disp(ex, "i"))),
+ if not(is(length(args(ex))=2)) then
+ /* The tex functions only cope with two arguments, so we have to use a string here! */
+ return(StackAddFeedback("", "Interval_wrongnumargs", stack_disp(string(ex), "i"))),
+ iop:op(ex),
+ il:first(args(ex)),
+ ir:second(args(ex)),
+ if real_numberp(il) and real_numberp(ir) and is(ir<il) then
+ ret:StackAddFeedback(ret, "Interval_backwards", stack_disp(ex, "i"), stack_disp(apply(iop,[ir, il]), "i")),
+ return(ret)
+)$
+
+/* Validate a realset, mostly for student feedback, so no errors thrown. */
+interval_validate_realset(ex) := block(
+ if trivialintervalp(ex) then return(""),
+ if setp(ex) then return(""),
+ if intervalp(ex) then return(interval_validate_single_interval(ex)),
+ if safe_op(ex)="%union" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ if safe_op(ex)="%intersection" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ return(StackAddFeedback("", "Interval_illegal_entries", stack_disp(ex, "i")))
+)$
+
+cc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right]")
+)$
+texput(cc, cc_interval_tex)$
+
+/* Note, the mismatching square brackets play havoc with the PHP interface. */
+co_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right)")*/
+ concat("!LEFTSQ! ", tex1(a),",\\, ",tex1(b), "!RIGHTR!")
+)$
+texput(co, co_interval_tex)$
+
+oc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right]")*/
+ concat("!LEFTR! ", tex1(a),",\\, ",tex1(b), "!RIGHTSQ!")
+)$
+texput(oc, oc_interval_tex)$
+
+oo_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right)")
+)$
+texput(oo, oo_interval_tex)$
+
+realset_tex(ex) := block([a, b, c],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ c:ev(interval_complement(b), simp),
+ if safe_setp(c) then
+ concat("{", tex1(a), " \\not\\in {",tex1(c), "}}")
+ else
+ concat("{", tex1(a), " \\in {",tex1(b), "}}")
+)$
+texput(realset, realset_tex)$
+
+/* Returns True if p is an element of A. False, otherwise: */
+
+inintervalp(p, A) := block ([Ans, Args, x, y, Atemp, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ Ans:false,
+ if not ev(real_numberp(p), simp) then
+ error("intervals: ",p," should be a real number"),
+
+ if atom(A) then Ans:false
+ elseif op(A)=set then
+ (
+ Atemp:listify(A),
+ n:length(Atemp),
+ while i<(n+1) do
+ (
+ if p=Atemp[i] then Ans:true,
+ i:i+1 )
+ )
+ elseif not( op(A)="[" ) then
+ (
+ Args:args(A),
+ x:first(Args),
+ y:last(Args),
+ if op(A)=cc then
+ (
+ if (p>=x and p<=y) then Ans:true
+ ),
+ if op(A)=oo then
+ (
+ if (p>x and p<y) then Ans:true
+ ),
+ if op(A)=co then
+ (
+ if (p>=x and p<y) then Ans:true
+ ),
+ if op(A)=oc then
+ (
+ if (p>x and p<=y) then Ans:true
+ )
+ )
+ elseif op(A)="[" then
+ (
+ n:length(A),
+ while j<n+1 do
+ (
+ Atemp:A[j],
+ Ans:inintervalp(p,Atemp),
+ if Ans=false then j:j+1 else j:n+1
+ )
+ )
+ else error("intervals: the interval, ",A,", is not of a recognised form"),
+ Ans
+)$
+
+intervalp(X) := block([A:X, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1)],
+ if atom(A) then return(false),
+
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+ if (op(A)=cc or op(A)=oo or op(A)=co or op(A)=oc) then return(true),
+ false
+)$
+
+realsetp(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(all_listp(real_numberp, args(ex))),
+ if intervalp(ex) then return(all_listp(real_numberp, args(ex))),
+ if op(ex)=%union then return(all_listp(realsetp, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realsetp, args(ex))),
+ return(false)
+)$
+
+/* Does not require all numbers to be actual real numbers. */
+realset_soft_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(realset_soft_p, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realset_soft_p, args(ex))),
+ return(false)
+)$
+
+/* Only looks at the very top level, used for validation */
+realset_surface_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(true),
+ if op(ex)=%intersection then return(true),
+ return(false)
+)$
+
+/* Make a real set, taking edge cases into account. This is also a top level function to convert true/false into all/none. */
+realsetmake(v, ex) := block(
+ if is(ex=false) then return(none),
+ if is(ex={}) then return(none),
+ if is(ex=%union()) then return(none),
+ if is(ex=%intersection()) then return(none),
+ if is(ex=true) then return(all),
+ if is(ex=all) or is(ex=none) or is(ex=unknown) then return(ex),
+ if atom(ex) then return(ex),
+ if is(safe_op(ex)="realset") then return(ex),
+ return(realset(v, ex))
+)$
+
+/* Predicate to remove trivial cases like oo(a,a) and co(-inf, -inf). */
+trivialintervalp(ex) := block(
+ if is(ex=all) or is(ex=none) then return(true),
+ if safe_setp(ex) and ex={} then return(true),
+ if not(intervalp(ex)) then return(false),
+ if safe_op(ex)="oo" and first(ex)=second(ex) then return(true),
+ if first(ex)=inf then return(true),
+ if second(ex)=-inf then return(true),
+ return(false)
+)$
+
+/* Return the number of separate connected components. */
+interval_count_components(ex) := block(
+ if not(realsetp(ex)) then error("interval_count_components"),
+ if ex=all then return(1),
+ if trivialintervalp(ex) then return(0),
+ if intervalp(ex) then return(1),
+ if setp(ex) then return(cardinality(ex)),
+ ev(apply("+", map(interval_count_components, args(ex))), simp)
+)$
+
+interval_simple_union(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then
+ Ans:B
+ elseif atom(B) then
+ Ans:A
+ elseif safe_setp(A) then (
+ if safe_setp(B) then
+ Ans:union(A,B)
+ else (
+ Args1:args(B),
+ x1:first(Args1),
+ y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if (Aset[i]<x1 or Aset[i]>y1) 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:i+1
+ ),
+ 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]<x1 or 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:i+1
+ ),
+ 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:false,
+ if first(Args1)=first(Args2) then (
+ if ( op(A)=co or op(A)=cc ) then
+ swap:false
+ elseif ( op(B)=co or op(B)=cc ) then
+ swap:true
+ else swap:false
+ ),
+ 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 (x2<y1 and y2>y1) 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 (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:interval_simple_union( A , {y2} )
+ else
+ Ans:A
+ ),
+ if (x2<y1 and y2<y1) then
+ Ans:A,
+ if x2=y1 then (
+ if ( (op(A)=co or op(A)=oo) and (op(B)=oo or op(B)=oc) ) then
+ Ans:[A,B]
+ else (
+ 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)
+ )
+ )
+ )
+ )
+ ),
+ Ans
+)$
+
+
+/* Finds the intersection of two "simple" real sets. */
+interval_simple_intersect(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, lopen:false, ropen:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+ if safe_setp(A) and safe_setp(B) then return(intersect(A,B)),
+ /* A & B are not both sets. */
+ if safe_setp(B) then (
+ A:Y,
+ B:X
+ ),
+ if safe_setp(A) then (
+ Args1:args(B),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if inintervalp(Aset[i],B) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 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:false,
+ if first(Args1)=first(Args2) then (
+ if (op(A)=co or op(A)=cc) then (
+ swap:false
+ ) elseif (op(B)=co or op(B)=cc ) then (
+ swap:true
+ ) else (
+ swap:false
+ )
+ ),
+ if is(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 (x2<y1 and y2>y1) 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 (x2<y1 and y2<y1) then
+ Ans:B,
+ if (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=oo) then lopen:true,
+ if (op(B)=oo or op(B)=co or op(A)=oo or op(A)=co) then ropen:true,
+ if (lopen and ropen) then Ans:oo(x2,y1),
+ if (lopen and not ropen) then Ans:oc(x2,y1),
+ if (not lopen and ropen) then Ans:co(x2,y1),
+ if (not lopen and not ropen) then Ans:cc(x2,y1)
+ ),
+ if x2=y1 then (
+ if ((op(A)=cc or op(A)=oc) and (op(B)=co or op(B)=cc)) then
+ Ans:{x2}
+ else
+ Ans:{}
+ ),
+ Ans
+)$
+
+interval_disjointp(A, B) := if interval_simple_intersect(A, B)={} then true else false$
+
+/* Is the ex1 contained within the real set ex2? */
+interval_subsetp(ex1, ex2) := block(
+ if not(realsetp(ex1)) then error("interval_subsetp expects its first argument to be a real set."),
+ if not(realsetp(ex2)) then error("interval_subsetp expects its second argument to be a real set."),
+ if interval_intersect(ex1, ex2) = ex1 then true else false
+)$
+
+/* Is the simple interval ex a explicitly a subinterval of EX? */
+interval_containsp(ex, EX) := block(
+ if not(intervalp(ex)) then error("interval_containsp expects its first argument to be a simple interval."),
+ if not(realsetp(EX)) then error("interval_containsp expects its second argument to be a real set."),
+ if is(ex=EX) then return(true),
+ if not(safe_op(EX)="%union" or safe_op(EX)="%intersection") then return(false),
+ if elementp(ex,setify(args(EX))) then return(true),
+ return(false)
+)$
+
+/* Top level intersection function which takes real sets, such as %unions. */
+interval_intersect(X,Y) := block([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if safe_op(A)="%intersection" then A:interval_intersect_list(args(A)),
+ if safe_op(B)="%intersection" then B:interval_intersect_list(args(B)),
+
+ if is(A=all) then return(B),
+ if is(B=all) then return(A),
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if not(listp(A)) and not(listp(B)) then return(interval_simple_intersect(A,B)),
+
+ /* Ensure we have lists to deal with, by making them lists of one element if needed. */
+ if not(listp(A)) then (temp:[], A:cons(A,temp) ),
+ if not(listp(B)) then (temp:[], B:cons(B,temp) ),
+
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (
+ A:A[1],
+ B:B[1],
+ return(interval_simple_intersect(A,B))
+ ) else (
+ while i<m+1 do (
+ while j<n+1 do (
+ temp:interval_simple_intersect(A[i], B[j]),
+ if not atom(temp) then (
+ Ans:append(Ans, [temp])
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ ),
+ if listp(Ans) then (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ ),
+ interval_tidy(Ans)
+)$
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+interval_intersect_list(X) :=
+ block ( [A:X, Ans, n, i, simp],
+ simp:true,
+ if X=[] then return({}),
+ n:length(A),
+ if n=1 then return(first(A)),
+ Ans:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ Ans:interval_intersect(Ans, A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+interval_intersect_nary([X]) := interval_intersect_list(X)$
+
+/* Given intervals, returns the same intervals but in ascending order of the first element in the interval. */
+interval_sort(X) := block([A:X, Ans:[], x, n, i],
+ if safe_op(X) = "%union" then A:args(X),
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do block(
+ if is(first(A[i]) < first(x)) then x:A[i],
+ i:ev(i+1,simp)
+ ),
+ Ans:append(Ans,[x]),
+ A:delete(x, A, 1),
+ n:ev(n-1, simp)
+ ),
+ /* %union does things to its arguments like moving -inf to the right with simp:true. */
+ /* Return a list to avoid killing the order here. */
+ Ans
+);
+
+/* Given a union of disjoint intervals,
+ checks whether any intervals are connected, and if so, joins them up and returns the ammended union. */
+interval_connect(X) := block([Ans, n, x, y, i:1],
+ if not(op(X)=%union or listp(X)) then error("interval_connect requires a %union or list of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ i:ev(i,simp),
+ if last( Ans[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:i+1
+ ),
+ 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],
+ if atom(X) then return(Ans:phi),
+ if listp(X) then X:apply(%union, X),
+ X:ev(X, %intersection=interval_intersect_nary),
+
+ if not(op(X)=%union or listp(X)) then (
+ Ans:X
+ ) else (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<ev(n+1, simp) do (
+ i:ev(i,simp),
+ if safe_setp(A[i]) then (
+ setpart:union(setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ) else if trivialintervalp(A[i]) then (
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ),
+ i:ev(i+1, simp)
+ ),
+ A:interval_sort(A),
+ if is(length(A)>1) 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
+ ),
+ 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 i<n+1 do
+ (
+ if length(setpart)>0 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:i+1
+ )
+ )
+ else Ans:A,
+ Ans
+)$
+
+/* Return the set complement of a real set. */
+interval_complement(X):= block([A:X, Ans:[], x, y, 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 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<n do (
+ temp:oo( A[i], A[i+1] ),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ i:i+1
+ ),
+ temp:oo(A[n], inf),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ apply(%union, Ans)
+)$
+
+/* Turns a single variable system over the reals in to a set of real numbers, together with insoluable bits (if any). */
+single_variable_solver_real(ex) := block([v, rs1, rs2],
+ if is(ex=false) then return(none),
+ if is(ex=true) then return(all),
+ if atom(ex) then return(ex),
+ v:listofvars(ex),
+ if is(length(v)=0) then block
+ (
+ if is(ratsimp(lhs(ex)-rhs(ex))=0) then
+ ex:all
+ else
+ ex:none
+ ),
+ if not(length(v)=1) then return(ex),
+ v:first(v),
+ ex:abs_replace_eq(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),
+
+ /* Notes,
+ (1) assume_pos automatically removes terms like v>=0 in the simplifier.
+ (2) we do need simplification here to reduce execution time.
+ */
+
+ if assume_pos then
+ ex:block([assume_pos:false], ev(single_variable_solver_real_rec(ex %and (v>=0), v), simp))
+ else
+ ex:ev(single_variable_solver_real_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),
+ rs1:realsetmake(v, rs1),
+ if is(rs1=none) then
+ ex:apply("%or", rs2)
+ else if is(rs1=all) then
+ ex:all
+ else
+ ex:realsetmake(v, rs1) %or apply("%or", rs2)
+ ),
+ if safe_op(ex)="%union" or safe_setp(ex) then
+ ex:realsetmake(v, ex),
+
+ return(ex)
+)$
+
+single_variable_solver_real_rec(ex, v) := block([r0, r1, r2],
+ if atom(ex) then return(ex),
+ if intervalp(ex) then return(ex),
+
+ if equationp(ex) then return(ev(equation_to_intervals(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], single_variable_solver_real_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)
+)$
+
+equation_to_intervals(ex, v) := block([sol0, sol1, sol2],
+ sol0: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),
+ sol1:flatten(setify(sol1)),
+ if is(length(sol2)=1) then
+ sol2:first(sol2)
+ else
+ sol2:apply("%or", sol2),
+ if emptyp(sol1) then
+ return(sol2),
+ return(sol1 %or sol2)
+)$
+
+/* Calculate the natural domain of a single-variable term. */
+natural_domain(ex) := block([v, ex2],
+ 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),
+ realsetmake(v, ex2)
+)$
+
+/* 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(single_variable_solver_real(first(args(ex))>=0)),
+ if safe_op(ex)="ln" or safe_op(ex)="log" or safe_op(ex)="lg" then
+ return(single_variable_solver_real(first(args(ex))>0)),
+ if safe_op(ex)="/" then
+ ex2:[natural_domain_rec(first(args(ex))), single_variable_solver_real((second(args(ex))>0) %or (second(args(ex))<0))]
+ else
+ 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),
+ ex2
+)$
diff --git a/stack/2020061000/maxima/noun_arith.lisp b/stack/2020061000/maxima/noun_arith.lisp
new file mode 100644
index 0000000..eff2e25
--- /dev/null
+++ b/stack/2020061000/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 $noun+ tex-mplus tex)
+(defprop $noun+ ("+") texsym)
+(defprop $noun+ 100. tex-lbp)
+(defprop $noun+ 100. tex-rbp)
+
+(defprop $noun- tex-prefix tex)
+(defprop $noun- ("-") texsym)
+(defprop $noun- 100. tex-rbp)
+(defprop $noun- 100. tex-lbp)
+
+(defprop $noun* tex-nary tex)
+(defprop $noun* "\\," texsym)
+(defprop $noun* 120. tex-lbp)
+(defprop $noun* 120. tex-rbp)
+
+(defprop $noun/ tex-mquotient tex)
+(defprop $noun/ 122. tex-lbp) ;;dunno about this
+(defprop $noun/ 123. tex-rbp)
+
+(defprop $noun^ tex-mexpt tex)
+(defprop $noun^ 140. tex-lbp)
+(defprop $noun^ 139. tex-rbp)
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+(defprop $nounand 65. tex-lbp)
+(defprop $nounand 65. tex-rbp)
+;;(defprop mand ("\\land ") texsym)
+(defprop mand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+(defprop $nounor 61. tex-lbp)
+(defprop $nounor 61. tex-rbp)
+;;(defprop mor ("\\lor ") texsym)
+(defprop mor ("\\,{\\mbox{ !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/2020061000/maxima/rtest_assessment_simpboth.mac b/stack/2020061000/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000..bc02f60
--- /dev/null
+++ b/stack/2020061000/maxima/rtest_assessment_simpboth.mac
@@ -0,0 +1,373 @@
+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'); ",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! ); ",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'); ",false]$
+irred_Q(9-3*x+3*x^5,x);
+[false,"stack_trans('irred_Q_commonint'); ",true]$
+
+irred_power_Qp(2,x);
+true$
+irred_power_Qp((x-1)^2,x);
+true$
+irred_power_Qp((3*x-6)^4,x);
+true$
+irred_power_Qp(x^2-1,x);
+false$
+irred_power_Qp(3*x-6*x^3+3*x^6,x);
+false$
+irred_power_Qp(9-3*x+3*x^5,x);
+true$
+
+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{false}\\)"$
+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]$
+
diff --git a/stack/2020061000/maxima/rtest_assessment_simpfalse.mac b/stack/2020061000/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000..e4228b9
--- /dev/null
+++ b/stack/2020061000/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*(1/x+1/1)$
+buggy_pow( 3*(x+1)^-2 );
+3*(1/x^2+1/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/2020061000/maxima/rtest_assessment_simptrue.mac b/stack/2020061000/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000..6f71fbf
--- /dev/null
+++ b/stack/2020061000/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/2020061000/maxima/rtest_elementary.mac b/stack/2020061000/maxima/rtest_elementary.mac
new file mode 100644
index 0000000..f0034a8
--- /dev/null
+++ b/stack/2020061000/maxima/rtest_elementary.mac
@@ -0,0 +1,179 @@
+zeroAdd(x);
+x$
+zeroAdd(0+x);
+x$
+zeroAdd(0+0+x);
+0+x$
+zeroAdd(x+0);
+x+0$
+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);
+x*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*1$
+oneMul(1^x);
+1^x$
+oneMul(x^1);
+x^1$
+oneMul(1*1*x);
+1*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$
+
+zPow(1);
+1$
+zPow(x^0);
+1$
+zPow(0^x);
+0^x$
+zPow(0^0);
+0^0$
+zPow(1+x);
+1+x$
+
+unaryAdd(x);
+x$
+unaryAdd("+"(x));
+x$
+unaryAdd("*"(x));
+"*"(x)$
+unaryAdd("+"(x,y));
+x+y$
+
+unaryMul("*"(x));
+x$
+unaryMul("*"(x,y));
+x*y$
+
+
+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$
+
+negNeg(x);
+x$
+negNeg(-x);
+-x$
+negNeg(-(-x));
+x$
+
+negZero(-x);
+-x$
+negZero(-0);
+0$
+negZero("-"(0));
+0$
+
+negDef(a-a);
+0$
+negDef(a+b-a);
+b$
+negDef(a-a-a);
+-a$
+negDef(a-a+b-b);
+0$
+
+negDistAdd(-(a+b));
+-a-b$
+
+intAdd(1+2);
+3$
+intAdd(1+x+2);
+x+3$
+
+intMul(2*3);
+6$
+intMul(2*x*3);
+6*x$
+
+intPow(2^3);
+8$
+intPow(2^x);
+2^x$
+intPow(0^0);
+0^0;
+
+
+
+
+
diff --git a/stack/2020061000/maxima/rtest_experimental.mac b/stack/2020061000/maxima/rtest_experimental.mac
new file mode 100644
index 0000000..e69de29
diff --git a/stack/2020061000/maxima/rtest_inequalities.mac b/stack/2020061000/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000..2498d27
--- /dev/null
+++ b/stack/2020061000/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)$
+1<x$
+
+inequality_disp(x-1<=%pi)$
+x<=1+%pi$
+
+inequality_disp(x>1);
+1<x$
+
+inequality_disp(2*x>%pi);
+%pi/2<x$
+
+inequality_disp(x>=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^2<x);
+x^2>x;
+
+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<x;
+
+rev_ineq(x>=6);
+6<=x;
+
+rev_ineq(x^2<x);
+x>x^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 6<x));
+x>6 and y>2$
+
+ineq_rem_redundant(1<x and x<%pi and x<20);
+x>1 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/2020061000/maxima/rtest_intervals.mac b/stack/2020061000/maxima/rtest_intervals.mac
new file mode 100644
index 0000000..b540ba0
--- /dev/null
+++ b/stack/2020061000/maxima/rtest_intervals.mac
@@ -0,0 +1,161 @@
+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/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(-1,-1/2),oo(-1/2,inf),oo(-inf,-1)))$
+
+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((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)))$
+
+single_variable_solver_real(x^2-4>0);
+realset(x,%union(oo(2,inf),oo(-inf,-2)))$
+
+single_variable_solver_real(2*x/abs(x-1)<1);
+(1-(2*x)/(x-1) > 0) %or ((2*x)/(x-1)+1 > 0)$
+
+single_variable_solver_real(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),{3},oc(-inf,0))$
+
+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/2020061000/maxima/sandbox.wxm b/stack/2020061000/maxima/sandbox.wxm
new file mode 100644
index 0000000..bd88b25
--- /dev/null
+++ b/stack/2020061000/maxima/sandbox.wxm
@@ -0,0 +1,85 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 13.04.2 ] */
+
+/* [wxMaxima: title start ]
+STACK Sandbox
+ [wxMaxima: title end ] */
+
+/* [wxMaxima: comment start ]
+This document loads the extra files needed for STACK.
+See https://github.com/maths/moodle-qtype_stack
+
+1. Set your operation system in the variable maximaplatform. For Windows set it to "win".
+2. If needed, set the stacklocation variable to the location of this sandbox file and the needed maxima and lisp files.
+3. 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 ] */
+/* No trailing slash. */
+maximaplatform:"linux"$
+stacklocation:"."$
+stacktmplocation:"/tmp"$
+
+/* For MS platforms you normally need to explicitly set the path.
+ Use the forward slash as a directory seperator.
+ You have cloned your code into c:/tmp/stackroot
+*/
+/*
+maximaplatform:"win"$
+stacklocation:"c:/tmp/stackroot/stack"$
+*/
+
+
+/****************************************************
+ 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, "/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/maxima/###.{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)$
+
+STACK_SETUP(ex):=block(
+ MAXIMA_VERSION_NUM_EXPECTED:41.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:"del",
+ GNUPLOT_CMD:"C:\\bin\\moodle\\server\\moodledata\\stack\\wgnuplot.exe",
+ MAXIMA_VERSION_EXPECTED:"5.42.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, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, 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, 0.01*Sv, m^2/s^2, 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{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}"],
+ stack_unit_other_unit_code:[min, amu, u, mmHg, bar, cc, gal, mbar, atm, torr, rev, deg, rpm, K, day, year, in, ft, mi],
+ stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 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), K, 86400*s, 3.156e7*s, in, 12*in, 5280*12*in],
+ stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{K}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{mi}"],
+ true)$
+/* Load the main libraries. */
+load("stackmaxima.mac")$
+load("stats")$
+load("distrib")$
+load("descriptive")$
+print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$
+/* [wxMaxima: input end ] */
+
+/* [wxMaxima: input start ] */
+/* Optional but useful. */
+display2d:true;
+simp:false;
+debug:true;
+/* [wxMaxima: input end ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2020061000/maxima/stack_logic.lisp b/stack/2020061000/maxima/stack_logic.lisp
new file mode 100644
index 0000000..2a1e162
--- /dev/null
+++ b/stack/2020061000/maxima/stack_logic.lisp
@@ -0,0 +1,678 @@
+#|
+; logic.mac--Logic algebra package for Maxima CAS.
+; Copyright (c) 2008--2009 Alexey Beshenov <al@beshenov.ru>.
+;
+; 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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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
+;
+;
+; TODO: 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/2020061000/maxima/stackmaxima.mac b/stack/2020061000/maxima/stackmaxima.mac
new file mode 100644
index 0000000..7b11a00
--- /dev/null
+++ b/stack/2020061000/maxima/stackmaxima.mac
@@ -0,0 +1,3185 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/* ********************************** */
+/* 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,
+ /* 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,
+
+ 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);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* Corresponds to current student expectations */
+alias(cosech,csch); /* Corresponds to current student expectations */
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+
+/* TODO: 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("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
+)$
+
+/* ********************************** */
+/* Load STACK packages */
+/* ********************************** */
+
+load("assessment.mac");
+load("inequalities.mac");
+load("intervals.mac");
+load("stackunits.mac");
+load("stacktex.lisp");
+load("stackstrings.mac");
+load("sregex");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+load("casanswertest.mac");
+load("errortostring.lisp");
+
+/* Breaks on older versions of Maxima. */
+if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+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 = "blank" then texput("*", "\\, ", nary)
+);
+
+make_logic(OPT_LOGIC) := block(
+ if OPT_LOGIC = "lang" then block(
+ texput("and", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("nounand", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("or", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nounor", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nand", "\\,{\\mbox{ !NAND! }}\\, ", nary),
+ texput("nor", "\\,{\\mbox{ !NOR! }}\\, ", nary),
+ texput("xor", "\\,{\\mbox{ !XOR! }}\\, ", nary),
+ texput("xnor", "\\,{\\mbox{ !XNOR! }}\\, ", nary),
+ texput("implies", "\\,{\\mbox{ !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)
+)$
+
+/* Options for cos^(-1), acos or arccos. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then block(
+ texput(asin, "\\sin^{-1}", prefix),
+ texput(acos, "\\cos^{-1}", prefix),
+ texput(atan, "\\tan^{-1}", prefix),
+ texput(asec, "{\\rm sec}^{-1}", prefix),
+ texput(acsc, "{\\rm csc}^{-1}", prefix),
+ texput(acot, "{\\rm cot}^{-1}", prefix),
+ texput(asinh, "{\\rm sinh}^{-1}", prefix),
+ texput(acosh, "{\\rm cosh}^{-1}", prefix),
+ texput(atanh, "{\\rm tanh}^{-1}", prefix),
+ texput(asech, "{\\rm sech}^{-1}", prefix),
+ texput(acsch, "{\\rm csch}^{-1}", prefix),
+ texput(acoth, "{\\rm coth}^{-1}", prefix)
+ ),
+ if OPT_ACOS = "arccos" then block(
+ texput(asin, "\\arcsin ", prefix),
+ texput(acos, "\\arccos ", prefix),
+ texput(atan, "\\arctan ", prefix),
+ texput(asec, "{\\rm arcsec}", prefix),
+ texput(acsc, "{\\rm arccsc}", prefix),
+ texput(acot, "{\\rm arccot}", prefix),
+ texput(asinh, "{\\rm arcsinh}", prefix),
+ texput(acosh, "{\\rm arccosh}", prefix),
+ texput(atanh, "{\\rm arctanh}", prefix),
+ texput(asech, "{\\rm arcsech}", prefix),
+ texput(acsch, "{\\rm arccsch}", prefix),
+ texput(acoth, "{\\rm arccoth}", prefix)
+ ),
+ if OPT_ACOS = "acos" then block(
+ texput(asin, "{\\rm asin}", prefix),
+ texput(acos, "{\\rm acos}", prefix),
+ texput(atan, "{\\rm atan}", prefix),
+ texput(asec, "{\\rm asec}", prefix),
+ texput(acsc, "{\\rm acsc}", prefix),
+ texput(acot, "{\\rm acot}", prefix),
+ texput(asinh, "{\\rm asinh}", prefix),
+ texput(acosh, "{\\rm acosh}", prefix),
+ texput(atanh, "{\\rm atanh}", prefix),
+ texput(asech, "{\\rm asech}", prefix),
+ texput(acsch, "{\\rm acsch}", prefix),
+ texput(acoth, "{\\rm acoth}", prefix)
+ )
+);
+
+
+/* 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);
+
+/* ****************************************************** */
+/* 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(
+ 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)
+)$
+
+/* Make a random selection of n different items from the list ex. */
+/* CJS, 7/6/2016 */
+rand_selection(ex, n) := block(
+ if not(listp(ex)) then (
+ error("rand_selection error: first argument must be a list."),
+ 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."),
+ 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)
+)$
+
+/* 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)<numcor then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ return([ta, version])
+)$
+
+/* Helper function for constructing MCQ arrays with auto-generated alphabetic labels. Students choose the labels. */
+multiselqnalpha([exs]):=block([corbase, numcor, wrongbase, numwrong, dispflag, ta1, ta2, ta3, talab, ta, version],
+ if length(exs)<4 then error("multiselqnalpha must have at least four arguments."),
+ corbase:first(exs),
+ numcor:second(exs),
+ wrongbase:third(exs),
+ numwrong:fourth(exs),
+ dispflag:"id",
+ if length(exs)>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)<numcor then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta3: random_permutation(append(ta1, ta2)),
+ /* Add in a slightly different display here. */
+ talab: ev(makelist(sconcat("(",ascii(96+i),")"), i, 1, length(ta3)), simp),
+ ta:zip_with(lambda([ex1, ex2], [ex1, ex2[2], sconcat("<b>", ex1, "</b> ",
+ 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)<numcor then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ /* */
+ corbase: zip_with("[", ev(makelist(k,k,1,length(corbase)),simp), corbase),
+ wrongbase: zip_with("[", ev(makelist(k,k,1+length(corbase),1+length(corbase)+length(wrongbase)),simp), wrongbase),
+ ta1: maplist(lambda([ex], [first(ex), true, second(ex)]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [first(ex), false, second(ex)]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ /* */
+ return([ta, version])
+)$
+
+/* Helper functions for MCQ arrays. */
+mcq_correct(ta):=block(
+ if not(listp(ta)) then error("mcq_correct: first argument must be a list, but was passed: ", string(ta)),
+ if not(all_listp(listp, ta)) then error("mcq_correct: 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_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)))))
+)$
+
+/* ********************************** */
+/* 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]])$
+
+/* 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],
+ %_tmp:[[_k, stack_dispvalue(_v)]],
+ if listp(%_tmp) then _DVALUES:append(_DVALUES,%_tmp),
+ 0)$
+_CS2dvv(_k,_v) := (_CS2v(_k,_v),_CS2dv(_k,_v),0)$
+
+/* ********************************** */
+/* Display */
+/* ********************************** */
+/* expr - expression to be displayed */
+/* m - mode, either */
+/* "i" inline or */
+/* "d" for displayed, or */
+/* "" for no delimiters. */
+/* ********************************** */
+
+stack_disp(expr, exprm) := block([str:"", expru],
+ /* LaTeX display */
+ if OPT_OUTPUT = "LaTeX" then
+ if not(ev(elementp(exprm, {"", "i", "d", "id"}), simp)) then print(concat("ERROR: illegal delimiter option found: ", exprm)),
+ /* Fine tune display, e.g. sort out display of atoms like theta0. */
+ expru: expr,
+ if not(stack_disp_control_structurep(expr)) then block(
+ expru: unary_minus_sort(expr),
+ expru: stack_disp_sub_script(expru)),
+
+ str: block([expstr, offset, ld, rd],
+ ld: "",
+ rd: "",
+ if exprm = "i" then block(ld: "\\(", rd:"\\)"),
+ if exprm = "id" then block(ld: "\\(\\displaystyle ", rd:"\\)"),
+ if exprm = "d" then block(ld: "\\[", rd:"\\]"),
+ mminusbp100(true),
+ expstr: tex(expru, false),
+ mminusbp120(true),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* String display */
+ if OPT_OUTPUT = "String" then str: string(expr),
+ /* If no correct options have been set. */
+ if str = "" then str:string(expr),
+ return(str)
+)$
+/* This function was renamed to improve the consistency of the coding style. */
+/* We continue to support the old name, since question authors may have used */
+/* it, even though that was not recommended practice. */
+alias(StackDISP, stack_disp)$
+
+/* If an expression contains these control structures then we don't fine-tune the display. */
+stack_disp_control_structurep(ex) := not(freeof(?mdoin, ?mdo, ?mcond, catch, throw, ":=", lambda, setelmx, ex))$
+
+stack_disp_strip_dollars(ex) := block(
+ if ?subseq(ex, 0, 2) = "$$" then
+ ex:?subseq(ex, 2, ev(?length(ex)-3, simp))
+ /* Remove \begin{verbatim}'s from Maxima's TEX command */
+ else if ?length(ex) > 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";
+?texnumformat(x) := if ev(floatnump(x),simp) then
+ ev(printf(false, stackfltfmt, x), simp) else if ev(integerp(x),simp) then (
+ if (is(stackintfmt="~r") or is(stackintfmt="~:r")) then
+ sconcat("\\mbox{",ev(printf(false, stackintfmt, x), simp),"}")
+ else
+ ev(printf(false, stackintfmt, x), simp)
+ ) else
+ string(x);
+/* 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),
+ 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..... */
+
+/* ******************************************* */
+/* Validate an expression */
+/* ******************************************* */
+
+/* List of variables, without some specific tokens in. */
+stack_validate_listofvars(ex) := block([lvars],
+ lvars:ev(setify(listofvars(ex)), simp),
+ lvars:ev(setdifference(lvars,{null, QMCHAR, EMPTYANSWER}), simp),
+ lvars:ev(sort(listify(lvars)), simp)
+)$
+
+stack_validate(expr, LowestTerms, TAns) := block([simp:false, exs, SameType, 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"),
+ 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 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, Equiv, fltfmt) := block([simp:false, exs, fvs, fvs1, fvs2],
+ /* If we have a float format, then use it. */
+ if not(is(fltfmt=false)) then
+ stackfltfmt:fltfmt,
+ /* 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 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])
+)$
+
+/* *************************************/
+/* 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],
+ 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(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ 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],
+ /* 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. */
+ tn: string(absolute_real_time()),
+ filename:concat("stackplot","-",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("<img src='", URL_BASE, filename, ".", PLOT_TERMINAL, "' alt='", str_to_html(alttext), "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class='stack_plot'>", ufn, "</div>"),
+ ufn: concat(" <html>", ufn, "</html> "),
+ /* 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]])
+ ),
+ /* Add in the command for the grid. */
+ if plotgrid2d and MAXIMA_VERSION_NUM>34 then
+ ral: append(ral, [grid2d]),
+ /* Note, the axes option in Maxima doesn't seem to work.... */
+ 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),
+ 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. */
+ 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)
+)$
+
+/* ********************************** */
+/* Numerical operations */
+/* ********************************** */
+
+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_displaydp(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(TA) then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_number"))
+ else
+ if numtype = "ABSOLUTE" then
+ return([true, numabsolutep(SA, SB, tol), "", ""])
+ else
+ return([true, numrelativep(SA, SB, tol), "", ""]),
+
+ 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<ta-tol, then f1<0. */
+ /* if abs(sa-ta)<abs(tol), then f2<0. */
+ /* We appear to need to calulate f1 & f2 as variables, */
+ /* otherwise Maxima's is complains "undefined". Odd... */
+ sa:first(sal),
+ ta:first(tal),
+ if type="ABSOLUTE" then
+ (f1:ev(float(sa-ta+tol),simp),
+ f2:ev(float(abs(sa-ta)-abs(tol)), simp))
+ else
+ (f1:ev(float(sa-ta*(1-tol)),simp),
+ f2:ev(float(abs(sa-ta)-abs(ta*tol)), simp)),
+ /*print([sa,ta,f1,f2]),*/
+ if is(f1<0) then return(num_compare_helper(rest(sal), tal, missing, append([sa], excessive), tol, type)),
+ if is(f2<0)
+ then return(num_compare_helper(rest(sal), rest(tal), missing, excessive, tol, type)),
+ return(num_compare_helper(sal, rest(tal), append([ta], missing), excessive, tol, type))
+)$
+
+ATNumSigFigs(SA, SB, SO) := block([simp, Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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("","ATNumSigFigs_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+ if listp(ol) then
+ if length(ol)#2 then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_list_wrong_length"), StackAddFeedback("", "TEST_FAILED_Q")]))
+ else
+ (nsf:ol[1], asf:ol[2])
+ else (nsf:ol, asf:ol),
+ if ev(not(integerp(nsf) and integerp(asf)), simp) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* Remove ephemeral forms from teacher's answers. */
+ SB:remove_displaydp(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)
+)$
+
+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)
+ )$
+
+/* ********************************** */
+/* 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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)
+)$
+
+/* 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,
+ /* 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 algebraic_equivalence(SA, SB) then
+ RawMark:true
+ else if algebraic_equivalence(exdowncase(SA), exdowncase(SB)) then
+ AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase"),
+ ret:[Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+ )$
+
+/* 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,
+
+ /* Trap edge cases. */
+ 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 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", ""]),
+ 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 single_variable_solver_real(SA)=single_variable_solver_real(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(
+ 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(
+ /* TODO: 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)<length(SA)) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_duplicates"),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_duplicates")
+ ),
+
+ /* We check the simplified sets. */
+ if (subsetp(SAsimp, SBsimp) and subsetp(SBsimp, SAsimp)) then
+ return([true, true, AnswerNote, FeedBack]),
+
+ /* Can we give feedback on which are wrong ? */
+ if not(emptyp(setdifference(SAsimp, SBsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_wrongentries", stack_disp(setdifference(SAsimp, SBsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_wrongentries")
+ ),
+ if not(emptyp(setdifference(SBsimp, SAsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_missingentries", stack_disp(setdifference(SBsimp, SAsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_missingentries")
+ ),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+/* We don't put in boolean_form, or noun_logic_remove here because that breaks (pre-existing) inequalities and equations. */
+ATSets_prepare(S) := ev(map(lambda([ex], ineqprepare(trigreduce(ex)) ), S), simp)$
+
+
+/* Maxima regular expressions. */
+ATSRegExp(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, patmatched],
+ 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("","ATSRegExp_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATSRegExp_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SA_not_string")),
+
+ patmatched:regex_match(SBsimp, SAsimp),
+
+ if listp(patmatched) then
+ return([true, true, StackAddNote("", sconcat("ATSRegExp: ", string(patmatched))), FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+/* 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]])
+)$
+
+
+/* A general, all purpose answer test which checks things are of the
+ same "type". Based upon the results of AtAlgEquivfun(SA,SB)
+*/
+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(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("", "ATSubstEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SB:errcatch(ev(SB, simp, nouns)),
+ if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_TAns"), ""]),
+ SB:SB[1],
+ /* 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),
+ 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(single_variable_solver_real(SA), simp),
+ SBP:ev(single_variable_solver_real(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],
+
+ 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(sa,sb) then
+ (RawMark:true, AnswerNote:"")
+ else
+ (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")),
+
+ if SA=SB then
+ return([Validity, true, StackAddNote("","ATCASEqual_true"), FeedBack]),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(SA,SB),
+ if ret[2]=false then
+ return([true, false, StackAddNote("ATCASEqual ", StackTrimNote(ret[3])), ret[4]]),
+ ret:block([simp:true, ret], ATAlgEquivfun(SA, SB)),
+ 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 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],
+ deg:ev(hipow(expand(p),v),simp),
+ /* Now perform the general test */
+ cl:ev(map(second,coeff_list_nz(expand(p),v)),simp),
+ /* 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 deg=0 then ret:[true,"",false],
+ /* Special situation for the linear case to avoid strange results */
+ if 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 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)
+);
+
+/* Is p a power of an irreducible term in v, over the rationals Q, disregarding the special case of a numerical factor? */
+/* Only used by ATPartFrac */
+/* Returns true/false */
+irred_power_Qp(p,v) := block([ret],
+ if safe_op(p)="^" then ret:irred_Q(first(args(p)),v) else ret:irred_Q(p,v),
+ if third(ret) then true else first(ret)
+);
+
+/* Picks apart an expression p of v, and gives some feedback */
+/* on why this is not a factored expression */
+FacForm_UnPick(SA, SO) := block([negdistrib, PARTSWITCH, fb, kloop, irred, res],
+ negdistrib:false,
+ partswitch:true,
+ fb:"",
+ res:true,
+ if atom(SA) then return([true, ""]),
+ if safe_op(SA) = "-" then SA:part(SA,1),
+ 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 atom(SB) then return([true,""]),
+ if safe_op(SB) = "-" then SA:part(SB,1),
+ if op(SB) = "+" then return(irred_Q(SB, SO)),
+ if 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? */
+/* Assumes all coefficients are integers. */
+
+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],
+ if errcatch(deg:hipow(expand(SA), SO)) = [] then block(
+ val: false,
+ rawmk: false,
+ ansnote: StackAddNote("", "ATFacForm_error_degreeSA"),
+ fb: StackAddFeedback("", "ATFacForm_error_degreeSA")
+ ),
+ aequiv:algebraic_equivalence(SA, SB),
+ SA:flatten(SA),
+ /* An integer answer is always correct. */
+ if (integerp(SA)) then
+ if (SA=SB) then
+ ansnote: StackAddNote("", "ATFacForm_int_true")
+ else block(
+ rawmk: false,
+ ansnote: StackAddNote("", "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 ( /* We need to provide some feedback, if possible */
+ ansnote:StackAddNote(ansnote, "ATFacForm_isfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_isfactored")
+ )
+ else
+ (up:FacForm_UnPick(SA, SO) ),
+ if (up[1]=false) then (
+ rawmk: false,
+ ansnote:StackAddNote(ansnote, "ATFacForm_notfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_notfactored"),
+ fb:concat(fb, up[2])
+ )
+ else
+ (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. */
+PartFracfun(sExpr, tExpr, wrt) := block([val, rawmk, ansnote, fb],
+ 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")
+ ),
+ /* ... with the degree(num)<degree(den) */
+ if not all_listp(lambda([ex],if denom(ex)=1 then true else is(ev(hipow(expand(num(ex)),wrt)<hipow(expand(denom(ex)),wrt),simp))),list) then
+ block(
+ rawmk: false,
+ ansnote:StackAddNote("","ATPartFrac_false_degree")
+ ),
+ /* We need to check that each denominator is the power of an irreducible factor */
+ /* Note the slight cludge to check if we have a numerical factor */
+ if not all_listp(lambda([ex],irred_power_Qp(denom(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)
+ )$
+
+/* ************************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, atoptions],
+ oldsimp:simp,
+ simp:false,
+ Validity:true, RawMark:false,
+ FeedBack:"", AnswerNote:"",
+ keepfloat:true,
+ /* Should we be fussy about the constant of integration? */
+ constint:true,
+ /* 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 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),
+ sbdisp:fourth(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, 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. */
+ATIntOptions(opts) := block([note, var, atopts, optdefaults],
+ note:"",
+ /* Add in default values for the options here. See ATIntOptionsHelper for details.*/
+ optdefaults:[true,[]],
+ if emptyp(opts) or not(is(length(opts)<4)) then return(["ATInt_STACKERROR_OptList", x, 0, true]),
+ var:first(opts),
+ atopts:ATIntOptionsHelper(rest(opts), optdefaults),
+ return(append([note, var], atopts))
+)$
+
+/* The second argument to this function is a list of all options in a *known order*.
+ We recurse over the list updating these. We seed the function with defualt values.
+ Options currenty are as follows:
+ [NOCONST, spdisp]
+ where
+ NOCONST = true or false. Are we strict in requiring a constant of integration?
+ 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.
+*/
+ATIntOptionsHelper(in, out) := block(
+ if emptyp(in) then return(out),
+ if is(first(in)=NOCONST) then return(ATIntOptionsHelper(rest(in), append([false], rest(out)))),
+ return(ATIntOptionsHelper(rest(in), [first(out), first(in)]))
+)$
+
+Intfun(SA, SB, SBdisp, constint, 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:false, 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("", "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)$
+
+/* Slight hack to compile these functions and hence suppress warnings. */
+load(linearalgebra);
+
+/* Stack expects some output with the version number the output happens at */
+/* maximalocal.mac after additional library loading */
+stackmaximaversion:2020061000$
diff --git a/stack/2020061000/maxima/stackreporting.mac b/stack/2020061000/maxima/stackreporting.mac
new file mode 100644
index 0000000..14f9dd7
--- /dev/null
+++ b/stack/2020061000/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/2020061000/maxima/stackstrings.mac b/stack/2020061000/maxima/stackstrings.mac
new file mode 100644
index 0000000..6d85976
--- /dev/null
+++ b/stack/2020061000/maxima/stackstrings.mac
@@ -0,0 +1,296 @@
+/* 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))
+)$
+
+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(i<slength(tmp)), simp) do (
+ c:charat(tmp, ev(i+1, simp)),
+ if is(mode="raw") then (
+ if is(c="[") then tokens:append(tokens,[_stackjson_tokens_list_open])
+ elseif is(c="]") then tokens:append(tokens,[_stackjson_tokens_list_close])
+ elseif is(c="{") then tokens:append(tokens,[_stackjson_tokens_dict_open])
+ elseif is(c="}") then tokens:append(tokens,[_stackjson_tokens_dict_close])
+ elseif is(c=":") then tokens:append(tokens,[_stackjson_tokens_key_sep])
+ elseif is(c=",") then tokens:append(tokens,[_stackjson_tokens_list_sep])
+ elseif is(c="\"") then (mode:"string",lastslash:false,r:"")
+ elseif is(c="n") and is(charat(tmp,i+2)="u") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="l") then (i:i+3, tokens:append(tokens,[und]))
+ elseif is(c="t") and is(charat(tmp,i+2)="r") and is(charat(tmp,i+3)="u") and is(charat(tmp,i+4)="e") then (i:i+3, tokens:append(tokens,[true]))
+ elseif is(c="f") and is(charat(tmp,i+2)="a") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="s") and is(charat(tmp,i+5)="e") then (i:i+4, tokens:append(tokens,[false]))
+ elseif not is(sposition(c,sconcat(ascii(32),ascii(9),ascii(10),ascii(11),ascii(12),ascii(13)))=false) then (i:i)
+ elseif is(c="-") then (mode:"number",r:["-"])
+ elseif digitcharp(c) then (mode:"number",r:[c])
+ ) elseif is(mode="string") then (
+ if(lastslash) then (
+ lastslash:false,
+ if is(c="\\") then r:sconcat(r,"\\")
+ elseif is(c="n") then r:sconcat(r,ascii(10))
+ elseif is(c="t") then r:sconcat(r,ascii(9))
+ elseif is(c="r") then r:sconcat(r,ascii(13))
+ elseif is(c="b") then r:sconcat(r,ascii(8))
+ elseif is(c="f") then r:sconcat(r,ascii(12))
+ elseif is(c="\"") then r:sconcat(r,"\"")
+ elseif is(c="u") then (r:sconcat(r,unicode(stack_string_hex_to_num(substring(tmp,i+2,i+6)))),i:i+4)
+ else r:sconcat(r,c)
+ ) else (
+ if is(c="\\") then lastslash:true
+ elseif is(c="\"") then (tokens:append(tokens,[r]),mode:"raw")
+ else r:sconcat(r,c)
+ )
+ ) elseif is(mode="number") then (
+ if digitcharp(c) then r:append(r,[c])
+ elseif is(c=".") then r:append(r,[c])
+ elseif is(c="e") then r:append(r,[c])
+ elseif is(c="E") then r:append(r,[c])
+ elseif is(c="+") then r:append(r,[c])
+ elseif is(c="-") then r:append(r,[c])
+ else (tokens:append(tokens,[stack_string_parse_number(simplode(r))]),i:i-1,mode:"raw")
+ ),
+ i:i+1
+ ),
+
+ /* In the unlikely case that we have an atomic value e.g. string or number exit early. */
+ if is(length(tokens)=1) then return(tokens[1]),
+ dm:0,
+ /* Otherwise reduce grouppings. */
+ starts:sublist_indices(tokens, lambda([x], is(x=_stackjson_tokens_list_open) or is(x=_stackjson_tokens_dict_open))),
+ while ev(is(length(starts)>0), simp) do (
+ r:[],
+ nt:[],
+ i:1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<last(starts)), simp) do (nt:append(nt,[tokens[i]]), i:ev(i+1, simp)),
+ if is(tokens[last(starts)]=_stackjson_tokens_list_open) then (
+ i:last(starts)+1,
+ while not is(tokens[i]=_stackjson_tokens_list_close) do (
+ if not is(tokens[i]=_stackjson_tokens_list_sep) then r:append(r,[tokens[i]]),
+ i:ev(i+1, simp)
+ )
+ ) else (
+ r:["stack_map"],
+ i:ev(last(starts)+1, simp),
+ while not ev(is(tokens[i]=_stackjson_tokens_dict_close), simp) do (
+ if not ev(is(tokens[i]=_stackjson_tokens_list_sep), simp) then (
+ k:tokens[i],
+ v:tokens[ev(i+2, simp)],
+ r:append(r,[[k,v]]),
+ i:ev(i+3, simp)
+ ) else i:ev(i+1, simp)
+ )
+ ),
+ nt:append(nt,[r]),
+ i:i+1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<length(tokens)+1), simp) do (nt:append(nt,[tokens[i]]),i:ev(i+1, simp)),
+ if ev(is(length(nt)<length(tokens)), simp) then dm:0,
+ tokens:nt,
+ /* If the string is bad we may loop forever for this we have an automated exit. */
+ dm:ev(dm+1, simp),
+ if ev(is(dm>20), 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)
+)$
+
+
+/* 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"
+ else if stringp(obj) then (
+ tmp:ssubst("\\\\","\\",obj),
+ tmp:ssubst("\\\"","\"",tmp),
+ tmp:ssubst("\\b",ascii(8),tmp),
+ tmp:ssubst("\\t",ascii(9),tmp),
+ tmp:ssubst("\\n",ascii(10),tmp),
+ tmp:ssubst("\\f",ascii(12),tmp),
+ tmp:ssubst("\\r",ascii(13),tmp),
+ r:sconcat("\"",tmp,"\"")
+ ) 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(obj) then r:string(obj)
+ else if numberp(obj) then r:string(float(obj))
+ else r:stackjson_stringify(string(obj)),
+ return(r)
+)$
+
+
+/**
+ * Special tools for dealing with CASText2, absolutely no use
+ * if you are not running a system with CASText2.
+ *
+ * Even if you have CASText2 enabled system these tools are very
+ * advanced and probably not for a novice author. Essenttially,
+ * 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.
+ */
+ if is(ct2[1]="jsxgraph") 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]))
+)$
diff --git a/stack/2020061000/maxima/stacktex.lisp b/stack/2020061000/maxima/stacktex.lisp
new file mode 100644
index 0000000..c4fd3ed
--- /dev/null
+++ b/stack/2020061000/maxima/stacktex.lisp
@@ -0,0 +1,444 @@
+;; 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.
+;; If changes are made here, then we also need to update arccos.lisp
+
+(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 "\\mbox{ }"))
+ ((eql (elt x 0) #\\) x)
+ (t (concatenate 'string "\\mbox{" x "}"))))
+
+;; 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 %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)))
+
+;; insert left-angle-brackets for mncexpt. a^<n> 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
+ (not (member f '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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, 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))))))
diff --git a/stack/2020061000/maxima/stacktex40.lisp b/stack/2020061000/maxima/stacktex40.lisp
new file mode 100644
index 0000000..9a7c45e
--- /dev/null
+++ b/stack/2020061000/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^<n> 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 '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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/2020061000/maxima/stackunits.mac b/stack/2020061000/maxima/stackunits.mac
new file mode 100644
index 0000000..59062c9
--- /dev/null
+++ b/stack/2020061000/maxima/stackunits.mac
@@ -0,0 +1,598 @@
+/* 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 <http://www.gnu.org/licenses/>.
+*/
+
+
+/****************************************************************/
+/* Simplified tools for handling SI-units (+liters) */
+/* */
+/* Matti Harjula <matti.harjula@aalto.fi> */
+/* */
+/* Answer test added by */
+/* Chris Sangwin <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* V0.5 August 2016 */
+/****************************************************************/
+
+/* This code is commented out as these lists are now defined in the main code and
+ 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),
+ 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<bestc) then (best:va,bestc:vb)
+ )
+ ),
+ return(best)
+ ) else (
+ va:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*value))),
+ vb:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*target))),
+ ii:is(stack_units_units(va)!=stack_units_units(vb)),
+ va:stack_units_nums(va),
+ if is(va = NULLNUM) then
+ va:1,
+ vb:stack_units_nums(vb),
+ if is(vb = NULLNUM) then
+ vb:1,
+ conversionfactor:va/vb,
+ va:stack_units_nums(stackunits_make(value)),
+ if is(va = NULLNUM) then
+ va:1,
+ va:va*conversionfactor,
+ vb:stack_units_units(stackunits_make(target)),
+ if ii
+ then error("Units presentation requires compatible units.")
+ else return(stackunits(va,vb))
+ )
+)$
+
+/* Splits off the units from the end of a product. */
+stackunits_make(ex) := block([oldsimp, exn, exu, exl],
+ if (debug) then (print("stackunits_make: "), print(ex)),
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+ oldsimp:simp,
+ simp:false,
+ /* If we have only a number then return it, with a placeholder for units. */
+ if simp_numberp(float(ex)) then return(stackunits(ex, NULLUNITS)),
+ /* Atoms should be returned as just units. */
+ if atom(ex) then
+ return(stackunits(NULLNUM, ex)),
+ if safe_op(ex)="stackunits" then
+ return(ex),
+ if is_simp(op(ex)=STACKpmOPT) then return(block([numa,numb],
+ if length(args(ex))=1 then
+ (
+ numa:NULLNUM,
+ numb:first(args(ex))
+ )
+ else
+ (
+ numa:first(args(ex)),
+ numb:second(args(ex))
+ ),
+ if (debug) then print("stackunits_make: found +-. Preliminary split as ", print(numa), print(numb)),
+ numb:stackunits_make(numb),
+ if (debug) then print("stackunits_make: +- results give ", print(numa), print(numb)),
+ verb_arith(stackunits(numa, second(args(numb)),first(args(numb))))
+ )
+ ),
+ /* We have a special case x*1/s which we need to filter out at this stage. */
+ if safe_op(ex)="/" then
+ ex:stackunits_make_recip(ex),
+ exn:flatten_recurse_nouns(noun_arith(ex)),
+ if (debug) then (print("stackunits_make: nounarith expression is"), print(exn)),
+ /* If the student has indicated +- we deal with this. */
+ /* If we don't have units we are return what we are given. */
+ if is_simp(listofunits(ex)=[]) then
+ return(stackunits(ex, NULLUNITS)),
+ /* Edge case like s^(-1). */
+ if is_simp(op(exn)="noun^") then
+ exn:[exn] elseif not(is_simp(op(exn)="noun*")) then
+ return(stackunits(ex, NULLUNITS)),
+ exu:sublist(args(exn), lambda([ex2], not(stackunits_make_p(ex2)))),
+ exn:sublist(args(exn), lambda([ex2], stackunits_make_p(ex2))),
+ simp:oldsimp,
+ if (debug) then (print("stackunits_make: expressions split as"), print(exn), print(exu)),
+ /* Flag up if we genuinely have no numbers. */
+ if is_simp(emptyp(exn)) then
+ exn:[NULLNUM],
+ /* Flag up if we genuinely have no units. */
+ if is_simp(emptyp(exu)) then
+ exu:[NULLUNITS],
+ /* Transform (a^2)^-1 to a^(-2), for the units. */
+ exu:maplist(unary_minus_remove, exu),
+ exu:maplist(flatten_pow_minus_one, exu),
+ if (debug) then (print("stackunits_make: (1) reformulated units as "), print(exu)),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ exn:maplist(unary_minus_remove, exn),
+ exn:stack_units_rational_number(exn),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ if is(first(exn) = UNARY_MINUS) then
+ (
+ exn:rest(exn),
+ exn[1]:ev(-1*exn[1],simp)
+ ),
+ if length(exn)=1 then exn:first(exn) else exn:apply("noun*", exn),
+ if length(exu)=1 then exu:first(exu) else exu:apply("noun*", exu),
+ if (debug) then (print("stackunits_make: (3) reformulated units as "), print(exu)),
+ verb_arith(stackunits(exn, exu))
+)$
+
+/* This function is deprecated. NO NOT USE. */
+stack_units_split(ex) := args(stackunits_make(ex))$
+
+/* Turn stackunits into a product in a safe way. */
+stackunits_to_product(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ return(ex),
+ if stack_units_units(ex) = NULLUNITS then
+ return(stack_units_nums(ex)),
+ if stack_units_nums(ex) = NULLNUM then
+ return(stack_units_units(ex)),
+ apply("*", args(ex))
+)$
+
+/* Predicate function used as a filter in stackunits_make. */
+stackunits_make_p(ex) := block(
+ if simp_numberp(ex) or is_simp(ex=UNARY_MINUS) or is_simp(ex=QMCHAR) then
+ return(true),
+ if emptyp(listofvars(ex)) then
+ return(true),
+ if simp_numberp(ev(float(verb_arith(ex)), simp)) then
+ return(true),
+ return(false)
+)$
+
+/* Does something look like a rational number? */
+stack_units_rational_number(ex) := block(
+ if length(ex)=1 and safe_op(first(ex))="noun^" and is(second(args(first(ex)))=-1) then return([1/first(args(first(ex)))]),
+ if not(length(ex)=2) then
+ return(ex),
+ if not(integerp(first(ex))) or atom(second(ex)) then return(ex),
+ if safe_op(second(ex))="noun^" and is(second(args(second(ex)))=-1) then return([first(ex)/first(args(second(ex)))]),
+ ex
+)$
+
+/* We have a special case x*1/s which we need to filter out at this stage. */
+stackunits_make_recip(ex) := block([ex1,ex2],
+ if not(safe_op(ex)="/") then
+ return(ex),
+ ex1:first(args(ex)),
+ ex2:second(args(ex)),
+ if not(safe_op(ex1)="*") then
+ return(ex),
+ ex1:reverse(args(ex1)),
+ if not(is_simp((first(ex1)=1)))
+ then return(ex),
+ if is(length(ex1)=2) then
+ return(second(ex1)/ex2),
+ reverse(rest(ex1))/ex2
+)$
+
+/* Add utility functions to get units and numerical parts. */
+stack_units_units(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(second(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(second(args(su))),
+ return(ex)
+)$
+
+stack_units_nums(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(first(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(first(args(su))),
+ return(ex)
+)$
+
+stack_units_err(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if not(is(safe_op(ex) = "stackunits")) then
+ return(0),
+ if is_simp(length(args(ex))=3) then
+ return(third(args(ex))),
+ return(0)
+)$
+
+stack_units_errp(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if length(args(ex))=3 then
+ return(true),
+ return(false)
+)$
+
+/* Validate an expression which is expected to have units. */
+stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:false, exs, SAU, SBU],
+ /* Check the display option. */
+ if not(fracdisp = "inline" or fracdisp = "negpow") then block(
+ error("stack_validate_units: fracdisp argument must be either inline or negpow only.")
+ ),
+ /* Try to simply the expression to catch CAS errors. */
+ exs:errcatch(ev(expr, simp)),
+ if is_simp(exs = []) then return(false),
+ if length(expr)#1 then
+ print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr:first(expr),
+ /* Declare all symobols as "units", and change their TeX display. */
+ stack_unit_si_declare(false),
+
+ /* An empty answer is validated as valid! */
+ if (expr = EMPTYANSWER) then return(expr),
+
+ /* Do not check for floats. They are always ok here. */
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and not(all_lowest_termsex(expr)) then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* SA should be only an expression. */
+ if not(expressionp(expr) or is(safe_op(expr)=STACKpmOPT)) then
+ (print(StackAddFeedback("", "ATUnits_SA_not_expression")), return(expr)),
+
+ /* Check if the student has correctly used units.*/
+ SAU:stackunits_make(expr),
+ SBU:stackunits_make(TAns),
+ if (debug) then (print("stack_validate_units working with: "), print(SAU), print(SBU)),
+
+ /* Deal with the display of floats. */
+ /* Only use the number template when we have exactly 1 float in the expression. */
+ stackfltfmt:"~a",
+ if numberp(stack_units_nums(SAU)) or is(safe_op(stack_units_nums(SAU)) = "-") then
+ stackfltfmt:fltfmt
+ else if is(safe_op(stack_units_nums(SAU)) = "*") then
+ if is(length(sublist(args(stack_units_nums(SAU)), numberp)) <= 1) then
+ stackfltfmt:fltfmt,
+
+ /* Check if stackunits_make appears to have done something sensible. */
+ /* Student types only units. This should always be invalid. */
+ if is_simp(stack_units_nums(SAU) = NULLNUM) then
+ print(StackAddFeedback("", "ATUnits_SA_only_units"))
+ else if not(emptyp(listofvars(stack_units_nums((SAU))))) then
+ print(StackAddFeedback("", "ATUnits_SA_bad_units"))
+ else block(
+ /* Student should use units if and only if the teacher uses units. */
+ if is_simp(stack_units_units(SAU) = NULLUNITS) and not(is_simp(stack_units_units(SBU) = NULLUNITS)) then
+ print(StackAddFeedback("", "ATUnits_SA_no_units")),
+ if not(is_simp(stack_units_units(SAU) = NULLUNITS)) and is_simp(stack_units_units(SBU) = NULLUNITS) then
+ print(StackAddFeedback("", "ATUnits_SA_excess_units"))
+ ),
+
+ /* Check if the student has added in error bounds. */
+ if stack_units_errp(SAU) then
+ print(StackAddFeedback("", "ATUnits_SA_errorbounds_invalid")),
+
+ /* Add in an option to control the display of the units. */
+ expr:SAU,
+ if (debug) then (print("stack_validate_units has: "), print(expr)),
+ if fracdisp = "inline" then
+ (
+ stack_disp_fractions("i"),
+ if stack_units_errp(SAU) then
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp), ev(stack_units_err(SAU),simp))
+ else
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp))
+ ),
+ if (debug) then (print(expr)),
+ expr:detexcolor(expr),
+ return(expr)
+)$
+
+/* Finer control over display of units, separating out the number from the units. */
+stackunitstex(ex) := block ([a, b, c, astr],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ astr:tex1(a),
+ if not(atom(a)) and safe_op(a)="+" and not(is(b=NULLUNITS)) then
+ astr:sconcat("\\left( ", astr, "\\right)"),
+ if length(args(ex))=3 then
+ astr:sconcat(astr, "\\pm ", third(args(ex))),
+ /* Fine tune the edge cases. */
+ if is(safe_op(b)="/") then
+ if (is(first(args(b))=1)) then return(sconcat(astr,"\\times ",tex1(b))),
+ /* Otherwise.... */
+ sconcat(astr,"\\, ",tex1(b))
+)$
+texput(stackunits, stackunitstex);
+texput(NULLUNITS, "");
+texput(NULLNUM, "");
+
+/* Units answer tests. */
+ATUnits(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsStrict(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsStrictSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Relative")$
+ATUnitsStrictRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Relative")$
+ATUnitsAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Absolute")$
+ATUnitsStrictAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Absolute")$
+
+/* This function has two options:
+ boolean: strictp determines if the test should be "strict" in requiging exactly the correct units.
+ numtest: string Chooses the numerical test applied to the numerical part.
+*/
+ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
+ SAU, SBU, SOU, SAU1, SBU1, SOU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ if (is(_EC(errcatch(SAA:ev(SA, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ if (is(_EC(errcatch(SBB:ev(SB, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ if (is(_EC(errcatch(SOO:ev(SO, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+
+ /* SA should be only an expression. */
+ if not(expressionp(SA)) then
+ return([false, false, StackAddNote("", "ATUnits_SA_not_expression"), StackAddFeedback("", "ATUnits_SA_not_expression")]),
+
+ /* SB should be only an expression. */
+ if not(expressionp(SB)) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATUnits_TA_not_expression"), StackAddFeedback("", "TEST_FAILED_Q")])),
+
+ /* SA must have some units. */
+ if simp_numberp(SA) then
+ return([false, false, StackAddNote("", "ATUnits_SA_no_units"), StackAddFeedback("", "ATUnits_SA_no_units")]),
+
+ /* Load and setup units. */
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+
+ if (debug) then (print("ATUnitsFun: raw input: "), print(SA), print(SB)),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(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)
+ 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)
+ 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/2020061000/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2020061000/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000..d4e798f
--- /dev/null
+++ b/stack/2020061000/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"<mspace/><fnm> %and </fnm><mspace/>" wxxmlsym)
+(defprop %and "<fnm> %and </fnm>" 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 "<mspace/><fnm> %or </fnm><mspace/>" wxxmlsym)
+(defprop %or "<fnm> %or </fnm>" 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/2020061000/maxima/unittests_load.mac b/stack/2020061000/maxima/unittests_load.mac
new file mode 100644
index 0000000..072158a
--- /dev/null
+++ b/stack/2020061000/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)$
+
+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/2020061000/maxima/utils.mac b/stack/2020061000/maxima/utils.mac
new file mode 100644
index 0000000..ea52d53
--- /dev/null
+++ b/stack/2020061000/maxima/utils.mac
@@ -0,0 +1,229 @@
+/* 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(string_to_escape) := block([tmp],
+ tmp: ssubst("&", "&", string_to_escape),
+ tmp: ssubst("'", "'", tmp), /* ' is for XHTML, we need to still deal with HTML. */
+ tmp: ssubst(""", "\"", tmp),
+ tmp: ssubst(">", ">", tmp),
+ tmp: ssubst("<", "<", tmp),
+ return(tmp)
+)$
+
+/* Same for generating ECMAScript strings. */
+str_to_js(string_to_escape) := block([tmp,lines],
+ tmp: ssubst("\\\\", "\\", string_to_escape),
+ tmp: ssubst("\\\"", "\"", tmp),
+ tmp: ssubst("\\'", "'", tmp),
+ tmp: ssubst("\\b", ascii(8), tmp),
+ tmp: ssubst("\\t", ascii(9), tmp),
+ tmp: ssubst("\\n", ascii(10), tmp),
+ tmp: ssubst("\\v", ascii(11), tmp),
+ tmp: ssubst("\\r", ascii(13), tmp), /* \b\t\v\r might as well set to "" but maybe someone uses them to do magic. */
+ return(tmp)
+)$
+
+/* 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 (
+ 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 (
+ 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", "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",
+ "errcatch", "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", "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"
+}$
+
+/* 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)
+)$
diff --git a/stack/2020070100/maxima/acos.lisp b/stack/2020070100/maxima/acos.lisp
new file mode 100644
index 0000000..52fec5c
--- /dev/null
+++ b/stack/2020070100/maxima/acos.lisp
@@ -0,0 +1,57 @@
+(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
diff --git a/stack/2020070100/maxima/arccos.lisp b/stack/2020070100/maxima/arccos.lisp
new file mode 100644
index 0000000..e784b26
--- /dev/null
+++ b/stack/2020070100/maxima/arccos.lisp
@@ -0,0 +1,54 @@
+(mapc #'tex-setup
+ '(
+ (%acos "\\arccos ")
+ (%asin "\\arcsin ")
+ (%atan "\\arctan ")
+
+ ; 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 arcsec}")
+ (%acsc "{\\rm arccsc}")
+ (%acot "{\\rm arccot}")
+ (%sech "{\\rm sech}")
+ (%csch "{\\rm csch}")
+ (%asinh "{\\rm arcsinh}")
+ (%acosh "{\\rm arccosh}")
+ (%atanh "{\\rm arctanh}")
+ (%asech "{\\rm arcsech}")
+ (%acsch "{\\rm arccsch}")
+ (%acoth "{\\rm arccoth}")
+
+)) ;; etc
diff --git a/stack/2020070100/maxima/assessment.mac b/stack/2020070100/maxima/assessment.mac
new file mode 100644
index 0000000..63cc178
--- /dev/null
+++ b/stack/2020070100/maxima/assessment.mac
@@ -0,0 +1,2359 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/****************************************************************/
+/* An assessment package for Maxima */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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 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)
+)$
+
+/* 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. */
+count_occurances(ex, v):=block(
+ if ex=v then return(1),
+ if atom(ex) then return(0),
+ apply("+", map(lambda([ex2], count_occurances(ex2, v)), 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 ret:apply("and", maplist(p, l)) else ret:"fail"$
+
+/* any_listp(p,l) true if all elements of l satisfy p. */
+any_listp(p, l) := if listp(l) then ret:apply("or", maplist(p, l)) else ret:"fail"$
+
+/* 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)))$
+
+/* 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!
+*/
+exdowncase(ex) := block([lv],
+ lv:listofvars(ex),
+ lv:map(lambda([v], v=parse_string(sdowncase(string(v)))),lv),
+ return(subst(lv,ex)))$
+
+/* 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")$
+
+
+/* ********************************** */
+/* Type predicates */
+/* ********************************** */
+
+/* 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)
+)$
+
+/* 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_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)="/" 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,
+ ex:errcatch(ev(fullratsimp(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)
+)$
+
+/* 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
+ 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)
+)$
+
+/* 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)) 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,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)))
+)$
+
+
+/* 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],
+ [n, dp]:args(ex),
+ ss:sconcat("~,", string(dp), "f"),
+ if is(equal(dp,0)) then ss:"~d",
+ ev(printf(false, ss, ev(float(n))), simp)
+);
+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(make_displaydpvalue, args(ex)))),
+ return(first(args(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) := 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],
+ [n, dp, expo]:args(ex),
+ ss:sconcat("~,", string(dp), "f \\times 10^{~a}"),
+ if is(equal(dp, 0)) then ss:"~d \\times 10^{~a}",
+ ev(printf(false, ss, ev(float(n)), expo), simp)
+)$
+texput(displaysci, displayscitex)$
+
+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)))
+)$
+
+/* ********************************** */
+/* 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, ex, vi],
+ /* 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,
+ /* 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. */
+ SA:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SA),
+ SB:subst(binomial=lambda([a,b],a!/(b!*(a-b)!)), SB),
+ if not(freeof(displaydp, SA)) then
+ SA:remove_displaydp(SA),
+ if not(freeof(displaydp, SB)) then
+ SA:remove_displaydp(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),
+ 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),
+ 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, stack_mtell_quiet],
+ stack_mtell_quiet:true,
+ /* 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. */
+ pvars:listofvars([p1,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(ev(p1-p2, lv, simp)),
+ if debug then print(lv, pval),
+ /* 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. (p1)"), return(false)),
+ pval:errcatch(ev(is(abs(first(pval)) > 1/10000), simp)),
+ if is(pval = []) then (print("STACK: ignore previous error. (p1)"), 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))),
+ /* Now we evaluate the difference of the expressions at each variable. */
+ p1:errcatch(ev(float(p1), lv, numer_pbranch:true, simp)),
+ if is(p1 = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ p2:errcatch(ev(float(p2), lv, numer_pbranch:true, simp)),
+ if is(p2 = []) then (print("STACK: ignore previous error. (p2)"), 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)),
+ /* print([p1,p2,sz]), */
+ if is(sz = []) then (print("STACK: ignore previous error."), return(false)),
+ if first(sz) > 0.0001 then true else 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(ex1,ex2):=block([lv1, lv2, lvi, lvp, lvs, lve, il, perm_size, simp],
+ 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:listify(setdifference(lv1, get_ops(ex1))),
+ lv2:listify(setdifference(lv2, get_ops(ex2))),
+ if length(lv1)#length(lv2) then return([]),
+ /* 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 (
+ lv1:setify(lv1),
+ lv2:setify(lv2),
+ lvi:intersection(lv1, lv2),
+ lv1:listify(setdifference(lv1, lvi)),
+ lv2:listify(setdifference(lv2, lvi))
+ ),
+ if length(lv1)>perm_size then return(false),
+ /* */
+ lvp:listify(permutations(lv2)),
+ /* Create a list of subsitutions */
+ lvs:map(lambda([ex], zip_with("=", lv1, ex)), lvp),
+ /* 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)))
+)$
+
+/* ********************************** */
+/* Noun arithmetic */
+/* ********************************** */
+
+/* ** Noun forms of the arithmetic functions ** */
+
+/* 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.
+*/
+
+/* Create noun forms of the functions of +, -, *, / and ^
+ as follows.
+ + noun+
+ - noun-
+ * noun*
+ / noun/
+ ^ noun^
+*/
+
+/* 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("noun=", 150);
+nary("noun+", 100);
+prefix("noun-", 100);
+nary("noun*", 120);
+infix("noun/", 122, 123);
+infix("noun^", 140, 139);
+prefix("UNARY_RECIP", 100);
+
+declare("noun*", commutative);
+declare("noun+", commutative);
+
+/* (2) */
+load("noun_arith.lisp");
+
+/* (3) */
+declare("noun=", commutative);
+declare("noun=", lassociative);
+declare("noun=", rassociative);
+
+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
+)$
+
+verb_arith(ex) := block([a],
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:subst("/", "noun/", ex),
+ ex:subst("^", "noun^", ex),
+ define(UNARY_RECIP a, a^(-1)),
+ ex:ev(ex, UNARY_MINUS=-1),
+ remfunction("noun+", "noun*", "noun/", "noun^", "noun-", "UNARY_RECIP"),
+ ex
+)$
+
+/* (4) */
+noun_arith(ex) := block([a],
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex),
+ /* Unary minus really communtes with multiplication. */
+ ex:subst(lambda([ex], UNARY_MINUS noun* ex), "-", ex),
+ /* Turn 1/x into x^(-1), in a special form */
+ ex:subst(lambda([ex1, ex2], ex1 noun* (UNARY_RECIP ex2)), "/", ex),
+ define(UNARY_RECIP a, a noun^ (-1)),
+ ex:ev(subst("noun^", "^", ex)),
+ remfunction("UNARY_RECIP"),
+ ev(ex)
+)$
+
+/* (5) Assumes we are working in the context of noun operators. */
+gather_reduce(ex) := block(
+ ex:subst("=", "noun=", ex),
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:ev(flatten(ex), simp),
+ ex:subst("noun=", "=", ex),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex), --
+ ex:subst("noun-", "-", 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)="noun+" or op(ex)="noun*" 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)="noun=" or safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="nounnot" or safe_op(ex)="nounset" or op(ex)="noun+" or op(ex)="noun*" 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)="noun^") then return(ex),
+ if not(second(args(ex))=-1) then return(ex),
+ if safe_op(first(args(ex)))="noun^" and integerp(second(args(first(args(ex))))) then return("noun^"(first(args(first(args(ex)))),-second(args(first(args(ex)))))),
+ ex
+);
+
+/* Recursive rule which takes UNARY_MINUS noun* n, where n is an integer to -n */
+unary_minus_remove(ex):= block(
+ if atom(ex) then return(ex),
+ if safe_op(ex)="noun*" and is(first(args(ex))=UNARY_MINUS) and integerp(second(args(ex))) then return(-second(args(ex))),
+ apply(op(ex), maplist(unary_minus_remove, args(ex)))
+);
+
+/* (7) */
+/* 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:subst(nounset,set,ex1),
+ ex2n:subst(nounset,set,ex2),
+ ex1n:noun_arith(ex1n),
+ ex2n:noun_arith(ex2n),
+ ex1n:flatten_recurse_nouns(ex1n),
+ ex2n:flatten_recurse_nouns(ex2n),
+ ex1n:sort_nouns(ex1n),
+ ex2n:sort_nouns(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"), ""]),
+
+ sa:remove_stackeq(sa),
+ sb:remove_stackeq(sb),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(sa,sb),
+ 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(sa, sb)),
+ 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(sa, sb) 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)$
+
+/****************************************************************/
+/* Define noun versions of logical "and" and "or". */
+/****************************************************************/
+
+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 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(integrate), 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);
+
+/* 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 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)
+)$
+
+/****************************/
+/* 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\\mbox{(?)}}");
+/* Here we add tags. These are for localisation. Dealt with on the PHP side in cassession -> instantiate. */
+texput(SAMEROOTS, "\\color{green}{\\mbox{!SAMEROOTS!}}");
+texput(ANDOR, "\\color{red}{\\mbox{!ANDOR!}}");
+texput(MISSINGVAR, "\\color{red}{\\mbox{!MISSINGVAR!}}");
+texput(ASSUMEPOSVARS, "\\color{blue}{\\mbox{!ASSUMEPOSVARS!}}");
+texput(ASSUMEREALVARS, "\\color{blue}{(\\mathbb{R})}");
+texput(ASSUMEPOSREALVARS, "\\color{blue}{\\mbox{!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("\\mbox{!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_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 ", FAA, " and ", FAB),
+ 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(
+ ATres:ev(ATAlgEquiv(SA, first(FBB)), simp),
+ if (debug) then print(ATres),
+ if second(ATres) then block(
+ 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(single_variable_solver_real(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.*/
+ note: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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+
+ /* 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/2020070100/maxima/assessment.texi b/stack/2020070100/maxima/assessment.texi
new file mode 100644
index 0000000..8e3b16f
--- /dev/null
+++ b/stack/2020070100/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} noun+ (@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} noun* (@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} noun^ (@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} noun- (@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 noun* 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 noun* ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 noun* (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<x,x<4])
+ (%i3) to_poly_solve(abs(x)<2,x);
+ (%o3) %union([-2<x,x<2])
+ @end example
+ These need to be incorporated, expanded and developed.
+@item A test which finds a mapping of variable names which makes two expressions equal (or returns ``false''). Also known as unification.
+@item Tests which deal with scientific units.
+@item Step-by-step derivation of standard types of problems.
+@item A larger range of buggy rules.
+@end enumerate
+
+@bye
+
+@chapter References
+
+@itemize @asis
+
+@mybibitem{Sangwin2010IGI}
+M. Badger and C.J. Sangwin. My equations are the same as yours!: computer aided assessment using a Grobner basis approach.
+In A. A. Juan, M. A. Huertas, and C. Steegmann, editors, Teaching Mathematics Online: Emergent Technologies and Methodologies. IGI Global, 2011.
+
+@end itemize
+
+@bye
+
+@mybibitem{Sangwin2009CalculumusII}
+R. Bradford, J. H. Davenport, and C. J. Sangwin. A comparison of equality in computer algebra and correctness in mathematical pedagogy. The International Journal for Technology in Mathematics Education, 2010.
+
+@mybibitem{Caviness1970}
+B. F. Caviness. On canonical forms and simplification. Journal of the ACM (JACM), 17(2):385-396, 1970.
+
+@mybibitem{CervalPena2008}
+E. R. Cerval-Pena. Automated computer-aided formative assessment with ordinary differential equations. Master's thesis, University of Birmingham, 2008.
+
+@mybibitem{Fenichel1966}
+R. R. Fenichel. An On-line System for Algebraic Manipulation. Phd thesis, Harvard Graduate School of Arts and Sciences, 1966.
+
+@mybibitem{Harjula2008}
+M. Harjula. Mathematics exercise system with automatic assessment. Master's thesis, Helsinki University of Technology, 2008.
+
+@mybibitem{Jenks1992}
+R. D. Jenks and R. S. Sutor. AXIOM: the scientific computation system. The Numerical Algorithms Group Ltd, 1992. ISBN: 0-387-07855-0.
+
+@mybibitem{Lowe2010}
+T. Lowe. e-Assessment using Symbolic Manipulation Tools. Technical report, Centre for Open Learning of Mathematics, Science, Computing and Technology, The Open University, 2010.
+
+@mybibitem{Moses1971}
+J. Moses. Algebraic simplification a guide for the perplexed. Communications of the ACM, 14(8):527-537, August 1971.
+
+@mybibitem{Nakamura2010}
+Y. Nakamura. The STACK e-Learning and Assessment System for mathematics, science and engineering education through Moodle, chapter Preface, pages vi-vii.
+Tokyo Denki University Press, 2010. In Japanese. ISBN 978-4-501-54820-9.
+
+@mybibitem{Rasila2007}
+A. Rasila, M. Harjula, and K. Zenger.
+Automatic assessment of mathematics exercises: Experiences and future prospects.
+In ReflekTori 2007: Symposium of Engineering Education, pages 70-80. Helsinki University of Technology, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2007.
+
+@mybibitem{Rasila2010}
+A. Rasila, L. Havola, Majander H., and J. Malinen. Automatic assessment in engineering mathematics: evaluation of the impact.
+In ReflekTori 2010: Symposium of Engineering Education. Aalto University, Finland, Teaching and Learning Development Unit, http://www.dipoli.tkk.fi/ok, 2010.
+
+@mybibitem{Richardson1966}
+D. Richardson. Solvable and Unsolable Problems Involving Elementary Functions of a Real Variable. PhD thesis, University of Bristol, 1966.
+
+@mybibitem{Ruokokoski2009}
+J. Ruokokoski. Automatic assessment in university-level mathematics. Master's thesis, Helsinki University of Technology, 2009.
+
+@mybibitem{SangwinTMA03}
+C. J. Sangwin. Assessing mathematics automatically using computer algebra and the internet. Teaching Mathematics and its Applications, 23(1):1-14, 2004.
+
+@mybibitem{Sangwin2006CASAlgebra}
+C. J. Sangwin. Assessing Elementary Algebra with STACK.
+International Journal of Mathematical Education in Science and Technology, 38(8):987-1002, December 2008.
+
+@mybibitem{2010STACKReport}
+C. J. Sangwin. Who uses STACK? A report on the use of the STACK CAA system. Technical report, The Maths Stats and OR Network, School of Mathematics, The University of Birmingham, 2010.
+
+@mybibitem{WebALT2006}
+C. J. Sangwin and M. J. Grove.
+STACK: addressing the needs of the ``neglected learners''. In Proceedings of the First WebALT Conference and Exhibition January 5-6, Technical University of Eindhoven, Netherlands, pages 81-95. Oy WebALT Inc, University of Helsinki, ISBN 952-99666-0-1, 2006.
+
+@mybibitem{Sleeman1982}
+D. Sleeman and J. S. Brown, editors. Intelligent Tutoring Systems. Academic Press, 1982.
+
+@mybibitem{Wild2009}
+I. Wild. Moodle 1.9 Math. Packt Publishing, 2009.
+
+@end itemize
+
+@bye
+
+
+@node Function and variable index, , Definitions for MYTOPIC, Top
+@appendix Function and variable index
+@printindex fn
+@printindex vr
+
+@bye
+
+@C \documentclass[11pt]{article}
+@C \newcommand{\href}[2]{#2}
+@C \begin{document}
+@C \bibliographystyle{plain}
+@C
+@C \cite{Jenks1992,Richardson1966,Caviness1970,Moses1971}\cite{Fenichel1966,Sleeman1982}\cite{Sangwin2010IGI,Sangwin2009CalculumusII}\cite{Sangwin2006CASAlgebra, WebALT2006,SangwinTMA03} \cite{CervalPena2008,Wild2009,Lowe2010,2010STACKReport}\cite{Rasila2007,Rasila2010,Ruokokoski2009,Harjula2008,Nakamura2010}.
+@C
+@C \bibliography{/Bib/education,/Bib/sangwin,/Bib/PUS,/Bib/MathsTexts,/Bib/CAA,/Bib/sr,/Bib/students}
+@C
+@C \end{document}
+
+@c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+@deffn {Function} expressionp (@var{ex})
+@end deffn
\ No newline at end of file
diff --git a/stack/2020070100/maxima/casanswertest.mac b/stack/2020070100/maxima/casanswertest.mac
new file mode 100644
index 0000000..b28d0f6
--- /dev/null
+++ b/stack/2020070100/maxima/casanswertest.mac
@@ -0,0 +1,254 @@
+/* This file contains functions used to wrap previously PHP side portions of
+ answertest processing over the existing CAS side logic to allow those tests
+ to be executed fully on CAS side. Some of this logic relies on the raw string
+ values of student inputs being available. */
+
+
+/* These are essentially the old atnumsigfigs.class.php with some validation happening outside this. */
+ATNumSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans) := block([allowextra,requiredsigfigs,requiredaccuracy,digits,result,Validity,RawMark,FeedBack,AnswerNote],
+ /* The return value */
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* First unpack the options. */
+ /* Note, in this test we first define the required number of significant digits,
+ no more no less, we may also define a second parameter that provides three
+ ways of function.
+
+ First for positive values, it defines the number of those significant digits
+ that need to match the correct ones. Makes no sense for this to be bigger than
+ the number of required digits.
+
+ Second for zero value it means that we do not care about the value only of the
+ form i.e. you can input any digits you want as long as they can be interpreted
+ as the correct number of significant digits.
+
+ Third for the special value of -1 it defines that we allow more significant
+ digits than what we require and that the value must match for those we require.
+ */
+ requiredsigfigs: 3,
+ requiredaccuracy: -1,
+ allowextra: false,
+
+ if listp(options) then (
+ requiredsigfigs: options[1],
+ requiredaccuracy: options[2]
+ ) else (
+ requiredsigfigs: options,
+ requiredaccuracy: options
+ ),
+
+ if ev(is(requiredaccuracy = -1),simp) then (
+ allowextra: true,
+ requiredaccuracy: requiredsigfigs
+ ),
+
+ /* What if the options do not make sense? */
+ /* Note that the options may now be dynamic and evaluated in CAS. */
+ if requiredsigfigs <= 0 or requiredaccuracy < 0 or not integerp(requiredsigfigs) or not integerp(requiredaccuracy) then (
+ return([false, false, "STACKERROR_OPTION.", ""])
+ ),
+
+ /* Find the number of digits. */
+ digits: sig_figs_from_str(rawsans),
+
+ if allowextra = true then (
+ if requiredsigfigs > 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 (
+ result: ATNumSigFigs(sans,tans,requiredaccuracy),
+ Validity: Validity and result[1],
+ RawMark: RawMark and result[2],
+ if result[3] # "" then (
+ AnswerNote: sconcat(AnswerNote, result[3])
+ ),
+ if result[4] # "" then (
+ FeedBack: sconcat(FeedBack, result[4])
+ )
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+
+ATSigFigsStrict_CASSigFigsWrapper(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])
+)$
+
+ATUnitsSigFigs_CASSigFigsWrapper(sans,tans,options,rawsans,strict) := block([tmp1, tmp2],
+ /* First the units and value */
+ tmp1: ATUnitsFun(sans, tans, options, strict, "SigFigs"),
+
+ /* If we do not have valid stuff for units tests we better drop out now. */
+ if is(tmp1[1] = false) then return(tmp1),
+
+ /* Then check the figures */
+ tmp2: ATNumSigFigs_CASSigFigsWrapper(
+ float(stack_units_nums(stack_unit_si_to_si_base(sans))),
+ float(stack_units_nums(stack_unit_si_to_si_base(tans))),options,rawsans),
+
+ /* Merge*/
+ return([tmp1[1] and tmp2[1], tmp1[2] and tmp2[2], sconcat(tmp1[3],tmp2[3]), sconcat(tmp1[4],tmp2[4])])
+)$
+
+ATNumDecPlaces_CASDecPlacesWrapper(sans,tans,options,rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote,required,val],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ RawMark: false,
+ Validity: false
+ ),
+
+ if Validity then (
+ /* 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])
+)$
+
+
+ATDecimalPlacesWrong(sans,tans,options) := block([Validity,RawMark,FeedBack,AnswerNote,_sans,_tans,required],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* 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_displaydp(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_STACKERROR_Option"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt"),
+ 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_displaydp(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/2020070100/maxima/cos-1.lisp b/stack/2020070100/maxima/cos-1.lisp
new file mode 100644
index 0000000..0881cb5
--- /dev/null
+++ b/stack/2020070100/maxima/cos-1.lisp
@@ -0,0 +1,56 @@
+(mapc #'tex-setup
+ '(
+ (%acos "\\cos^{-1}")
+ (%asin "\\sin^{-1}")
+ (%atan "\\tan^{-1}")
+
+ ; 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.
+
+ ; Maxima built-in functions which do not have corresponding TeX symbols.
+ (%asec "{\\rm sec}^{-1}")
+ (%acsc "{\\rm csc}^{-1} ")
+ (%acot "{\\rm cot}^{-1}")
+ (%sech "{\\rm sech}")
+ (%csch "{\\rm csch}")
+ (%asinh "{\\rm sinh}^{-1}")
+ (%acosh "{\\rm cosh}^{-1}")
+ (%atanh "{\\rm tanh}^{-1}")
+ (%asech "{\\rm sech}^{-1}")
+ (%acsch "{\\rm csch}^{-1}")
+ (%acoth "{\\rm coth}^{-1}")
+
+)) ;; etc
+
diff --git a/stack/2020070100/maxima/elementary.mac b/stack/2020070100/maxima/elementary.mac
new file mode 100644
index 0000000..4a97fa2
--- /dev/null
+++ b/stack/2020070100/maxima/elementary.mac
@@ -0,0 +1,521 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+
+/* 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 */
+
+/* http://www.ncl.ac.uk/math/numbas/manual.pdf and
+https://github.com/numbas/Numbas/blob/master/runtime/scripts/jme-display.js#L749
+
+ unitDenominator transform x/1 to x
+ zeroPower transform x^0 to 1
+ simplifyFractions transform (a*b)/(a*c) to b/c
+ zeroBase transform 0^x to 0
+ sqrtProduct simplify sqrt(a)*sqrt(b) to sqrt(a*b)
+ sqrtDivision simplify sqrt(a)/sqrt(b) to sqrt(a/b)
+ sqrtSquare simplify sqrt(x^2) to x
+ trig simplify various trigonometric values e.g. sin(n*pi) to 0
+ otherNumbers simplify 2^3 to 8
+ fractionNumbers display all numbers as fractions instead of decimals
+*/
+
+/* NOTE: all these operations really need three separate
+things, as with zeroAdd:
+
+zeroAddp - the predicate which matches to the pattern zeroAdd -
+perform the rule on the top level. zeroAddr - recurse over the
+whole expression applying the rule.
+
+What about working through to the first occurance of the
+pattern?
+
+What about identifying the first occurance of where a rule is
+satisfied?
+
+*/
+
+/*******************************************/
+/* Control functions */
+/*******************************************/
+
+/* List of all available rules */
+ID_TRANS:["zeroAdd","zeroMul","oneMul","onePow","idPow","zeroPow","zPow"]$
+ALG_TRANS:["assAdd","assMul","unaryAdd","unaryMul","comAdd","comMul"]$
+NEG_TRANS:["negZero","negDef","negNeg","negInt","negMinusOne","negDistAdd","negProdA","negProdB"]$
+INT_ARITH:["intAdd","intMul","intPow"]$
+DIV_TRANS:["oneDiv","idDiv","divDivA","divDivB","recipDef","recipNeg","recipMul"]$
+DIS_TRANS:["disAddMul"]$
+POW_TRANS:["powLaw"]$
+ALL_TRANS:append(ALG_TRANS,ID_TRANS,INT_ARITH,NEG_TRANS,DIV_TRANS,DIS_TRANS,POW_TRANS)$
+
+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)))$
+
+
+/* Transform recursively accross an expression*/
+transr(ex,rl):=block(
+ if atom(ex) then return(ex),
+ if listp(rl) then error("transr: only apply one rule using transr"),
+ if trans_topp(ex,rl) then
+ /* If applying the rule changes the expression then do so */
+ block([ex2], ex2:apply(parse_string(rl),[ex]), if ex=ex2 then ex else transr(ex2,rl) )
+ else return(map(lambda([ex2],transr(ex2,rl)),ex))
+)$
+
+/* Apply a list of rules recursively, in order, once each */
+transl(ex,rll):=block(
+ if atom(ex) or not(listp(rll)) or emptyp(rll) then return(ex),
+ return(transl(transr(ex,first(rll)),rest(rll)))
+)$
+
+/*******************************************/
+/* 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)))
+)$
+
+
+/*******************************************/
+/* Transformation rules */
+/*******************************************/
+
+/* 0+x -> x */ /* Strictly zero at the first part */
+zeroAddp(ex):= block(
+ if safe_op(ex)="+" and is(part(ex,1)=0) then true else false
+)$
+
+zeroAdd(ex) := block(
+ if zeroAddp(ex) then
+ return( block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("+",rest(args(ex)))))),
+ return(ex)
+)$
+
+/* zeroMul transform 0*x to 0 */
+zeroMulp(ex) := block(
+ if safe_op(ex)="*" and is(part(ex,1)=0) then true else false
+)$
+
+zeroMul(ex) := block(
+ if zeroMulp(ex) then return(0) else return (ex)
+)$
+
+/* oneMul transform 1*x to x */
+oneMulp(ex) := block([ex2],
+ if safe_op(ex)="*" and is(part(ex,1)=1) then true else false
+)$
+
+oneMul(ex) := block([ex2],
+ if oneMulp(ex) then
+ return(block([ex2],ex2:rest(args(ex)), if equal(length(ex2),1) then return(part(ex,2)) else return(apply("*",rest(args(ex))))))
+ else return(ex)
+)$
+
+/* 1^x -> 1 */
+onePowp(ex):=block(
+ if safe_op(ex)="^" and is(part(ex,1)=1) then true else false
+)$
+
+onePow(ex):= if onePowp(ex) then 1 else ex$
+
+/* x^1 -> x */
+idPowp(ex):=block(
+ if safe_op(ex)="^" 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 safe_op(ex)#"^" 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 safe_op(ex)#"^" 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$
+
+/* "+"(x) -> x. (Probably not needed, but we may end up with sums of lists of length 1.)*/
+unaryAddp(ex):= block(
+ if safe_op(ex)="+" and length(args(ex))=1 then true else false
+)$
+
+unaryAdd(ex):= if unaryAddp(ex) then first(args(ex)) else ex$
+
+/* "*"(x) -> x. (Probably not needed.)*/
+unaryMulp(ex):= block(
+ if safe_op(ex)="*" and length(args(ex))=1 then true else false
+)$
+
+unaryMul(ex):= if unaryMulp(ex) then first(args(ex)) 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)="+" and flatten(ex)#ex then true else false$
+assAdd(ex) := if assAddp(ex) then flatten(ex) else ex$
+
+assMulp(ex):= if safe_op(ex)="*" and flatten(ex)#ex then true else false$
+assMul(ex) := if assMulp(ex) then flatten(ex) else ex$
+
+/* Define a predicate to sort elements, NEG at the front, RECIP at the end. */
+orderelementaryp(exa,exb):=block(
+ if exa=NEG then return(true),
+ if exb=NEG then return(false),
+ if safe_op(exa)="RECIP" and safe_op(exb)="RECIP" then return(orderlessp(part(exa,1),part(exb,1))),
+ if safe_op(exa)="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)#"RECIP")),
+ l2:sublist(l, lambda([ex],not(atom(ex)) and safe_op(ex)="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)="+" and apply("+",elsort(args(ex)))#ex then true else false$
+comAdd(ex) := if comAddp(ex) then apply("+",elsort(args(ex))) else ex$
+
+comMulp(ex):= if safe_op(ex)="*" and apply("*",elsort(args(ex)))#ex then true else false$
+comMul(ex) := if comMulp(ex) then apply("*",elsort(args(ex))) else ex$
+
+/*******************************************/
+/* Double negation -(-(a)) */
+negNegp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if safe_op(part(ex,1))="-" then return(true) else return(false)
+)$
+
+negNeg(ex):=if negNegp(ex) then part(ex,1,1) else ex$
+
+/* -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))
+)$
+
+/* Negation of zero -0 -> 0 */
+negZerop(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if is(part(ex,1)=0) then return(true) else return(false)
+)$
+
+negZero(ex):=if negZerop(ex) then 0 else ex$
+
+/* Turns the negation of an integer into an actual integer "-"(n) -> -n */
+negIntp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if integerp(part(ex,1)) then return(true) else return(false)
+)$
+
+negInt(ex):=if negIntp(ex) then ev(ex,simp) else ex$
+
+/* Turns unary minus in a product into a special symbol NEG */
+negProdAp(ex):=block(
+ if safe_op(ex)#"*" then return(false),
+ return(any_listp(lambda([ex],if safe_op(ex)="-" then true else false),args(ex)))
+)$
+
+negProdA(ex):=block(
+ if negProdAp(ex)=false then return(ex),
+ apply("*",maplist(lambda([ex],if safe_op(ex)="-" then NEG*first(args(ex)) else ex),args(ex)))
+)$
+
+/* matches up to NEG*... and turns this back into unary minus... */
+negProdBp(ex):=if safe_op(ex)="*" and first(args(ex))=NEG then true else false$
+
+negProdB(ex):=block(
+ if negProdBp(ex)=false then return(ex),
+ -apply("*",rest(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)
+)$
+
+
+/* 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)))
+)$
+
+/* 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)
+)$
+
+/* 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
+)$
+
+/*******************************************/
+/* Warning, this is not safe on non-atoms, it evaluates them! */
+notintegerp(ex):= if atom(ex) then not(integerp(ex)) else true$
+
+/* Evaluate integer arithmetic */
+intAddp(ex):=block(
+ if safe_op(ex)#"+" then return(false),
+ if length(sublist(args(ex), integerp))>1 then return(true) else return(false)
+)$
+
+intAdd(ex):=block([a1,a2],
+ if intAddp(ex)=false then return(ex),
+ a1:sublist(args(ex), integerp),
+ a1:ev(apply("+",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1+first(a2)
+ else a1+apply("+",a2)
+)$
+
+intMulp(ex):=block(
+ if safe_op(ex)#"*" 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), integerp),
+ a1:ev(apply("*",a1),simp),
+ a2:sublist(args(ex), notintegerp),
+ if length(a2)=0 then a1
+ else if length(a2)=1 then a1*first(a2)
+ else apply("*",append([a1],a2))
+)$
+
+intPowp(ex):=block(
+ if safe_op(ex)#"^" 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)
+)$
+
+/*******************************************/
+/* Division rules */
+
+/* a/1 -> a */
+oneDivp(ex):= if safe_op(ex)="/" and part(ex,2)=1 then true else false$
+oneDiv(ex) := if oneDivp(ex) then part(ex,1) else ex$
+
+/* 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$
+
+/* a/(b/c)-> a*(c/b) */
+divDivAp(ex) := if safe_op(ex)="/" and safe_op(part(ex,2))="/" then true else false$
+divDivA(ex) := if divDivAp(ex) then part(ex,1)*(part(ex,2,2)/part(ex,2,1)) else ex$
+
+/* (a/b)/c-> a/(c*b) */
+divDivBp(ex) := if safe_op(ex)="/" and safe_op(part(ex,1))="/" then true else false$
+divDivB(ex) := if divDivBp(ex) then part(ex,1,1)/(part(ex,1,2)*part(ex,2)) else ex$
+
+/*******************************************/
+/* RECIP */
+
+/* re-write a/b as RECIP */
+
+recipDefp(ex) := if safe_op(ex)="/" then true else false$
+recipDef(ex) := if recipDefp(ex) then part(ex,1)*RECIP(part(ex,2))$
+
+/* RECIP(-x) -> -RECIP(x) */
+recipNegp(ex) := if safe_op(ex)="RECIP" and safe_op(part(ex,1))="-" then true else false$
+recipNeg(ex) := if recipNegp(ex) then -RECIP(part(ex,1,1)) else ex$
+
+/* a*RECP(b)*RECIP(c) -> a*RECIP(b*c) */
+recipMulp(ex) := block([l],
+ if safe_op(ex)#"*" then return(false),
+ if length(args(ex))=1 then return(false),
+ l:reverse(args(ex)),
+ if safe_op(first(l))="RECIP" and safe_op(second(l))="RECIP" then true else false
+)$
+
+recipMul(ex) := block([p1,p2],
+ if recipMulp(ex)#true then return(ex),
+ l:reverse(args(ex)),
+ apply("*",append(reverse(rest(rest(l))),[RECIP(part(second(l),1)*part(first(l),1))]))
+)$
+
+/*******************************************/
+/* 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)
+);
+
+/*******************************************/
+/* Buggy rules */
+
+/* (a+b)^n -> a^n+b^n */
+buggyPowp(ex):=block(
+ if safe_op(ex)#"^" then return(false),
+ if safe_op(part(ex,1))="+" then true else false
+)$
+
+buggyPow(ex):= if buggyPowp(ex) then apply("+",map(lambda([ex2],ex2^part(ex,2)),args(part(ex,1)))) else ex$
+
+/* -(a+b) -> -a+b */
+buggyNegDistAddp(ex) := negDistAddp(ex)$
+buggyNegDistAdd(ex) := if buggyNegDistAddp(ex) then apply("+",append([-first(args(part(ex,1)))],rest(args(part((ex),1))))) else ex$
+
+
+/*******************************************/
+/* Testing */
+simp:false;
+/*STT:batch("rtest_elementary.mac", test);*/
+simp:false;
+
+
+
diff --git a/stack/2020070100/maxima/errortostring.lisp b/stack/2020070100/maxima/errortostring.lisp
new file mode 100644
index 0000000..df6ba14
--- /dev/null
+++ b/stack/2020070100/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/2020070100/maxima/expandfeedback.mac b/stack/2020070100/maxima/expandfeedback.mac
new file mode 100644
index 0000000..8d688ae
--- /dev/null
+++ b/stack/2020070100/maxima/expandfeedback.mac
@@ -0,0 +1,139 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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)$
+
+
+/* This function applies the binary function f to two lists a and b
+ returning a list [ f(a[1],b[1]), f(a[2],b[2]), ... ]
+ zip_with quietly gives up when one of the list runs out of elements. */
+zip_with(f,a,b) := block(
+ if listp(a)= false then return(false),
+ if listp(b)= false then return(false),
+ if a = [] then return([]),
+ if b = [] then return([]),
+ cons(f(first(a),first(b)),zip_with(f,rest(a),rest(b)))
+)$
+
+/* 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/2020070100/maxima/experimental.mac b/stack/2020070100/maxima/experimental.mac
new file mode 100644
index 0000000..3ee1f9e
--- /dev/null
+++ b/stack/2020070100/maxima/experimental.mac
@@ -0,0 +1,167 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/* 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))));
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 January 2013 */
+/* */
+/****************************************************************/
+
+/* Sample ways of representing a PRT in which we might have errors */
+
+/* Evaluate a single node safely. */
+node_no(prt,num,inputs) := block([res,err],
+ /* Type checking */
+ if not(listp(prt)) then error("node_no expects its first argument to be a list."),
+ if not(integerp(num)) then error("node_no expects its second argument to be an integer."),
+ if is(length(prt)<num) then error("node_no expects its second argument to less than the length of the first."),
+ /* Do computation */
+ res:errcatch(ev(prt[num],inputs,nouns)),
+ if is([] = res) then
+ print(concat("Previous error generated by node number ", string(num), ".")),
+ if is([] = res) then
+ []
+ else
+ first(res)
+ );
+
+/* Actually traverse the PRT with given inputs */
+/* Inputs should be in the form of equations such as [ans1=x^2] */
+traverse_prt(inputs) := block(
+ /* Type checking */
+ if not(listp(inputs)) then error("traverse_prt expects its argument to be a list."),
+ if not(alllistp(equationp,inputs)) then error("traverse_prt expects its argument to be a list of equations."),
+ /* Setup PRT */
+ simp:false,
+ PRTtests:[
+ 'ATAlgEquiv(ans1,x^3),
+ 'ATInt(ans2,[x^3,x]),
+ 'ATInt(ans2/0,[x^3,x])
+ ],
+ quiet:[false,false,false],
+ nexttrue:[2,3,1],
+ nextfalse:[1,1,1],
+ /* Creatlist to store previously visited nodes */
+ visited:makelist(false, length(PRTtests)),
+ current_node:1,
+ feedback:[],
+ answernote:[],
+ /* Actually traverse the tree */
+ while not(visited[current_node]) do block([res],
+ visited[current_node]:true,
+ res:node_no(PRTtests,current_node,inputs),
+ if not(listp(res)) then return(false),
+ /* Feedback */
+ if not(quiet[current_node]) then feedback:cons(res[4], feedback),
+ feedback:cons(concat("[STACK-feedback:",string(current_node),"-",string(res[2]),"]"), feedback),
+ /* Answernotes */
+ if not(is(res[3] = "")) then answernote:cons(res[3], answernote),
+ answernote:cons(concat(string(current_node),"-",string(res[2])), answernote),
+ /* Update to next node */
+ if res[2] then
+ current_node:nexttrue[current_node]
+ else
+ current_node:nextfalse[current_node]
+ ),
+ answernote:simplode(reverse(sublist(answernote, lambda([ex],not(is(ex=""))))), " | " ),
+ feedback:simplode(reverse(sublist(feedback, lambda([ex],not(is(ex=""))))), " | " ),
+ [answernote, feedback]
+)$
+
+print("[ STACK-reports started. ]")$
+
+/****************************************************************/
+/* Unary minus functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.1 March 2014 */
+/* */
+/****************************************************************/
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_minus_simp(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and first(args(ex))<0 then return(ev(ex,simp)),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "-" then return(first(args(first(args(ex))))),
+ apply(op(ex), map(unary_minus_minus_simp, args(ex)) )
+)$
+
+/* Transforms --x into x recursively in the case simp:false */
+unary_minus_add_distrib(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex) = "-" and atom(first(args(ex))) then return(ex),
+ if op(ex) = "-" and op(first(args(ex))) = "+" then return(apply("+", map(lambda([ex2],-ex2), args(first(args(ex)))))),
+ apply(op(ex), map(unary_minus_add_distrib, args(ex)) )
+)$
+
+/****************************************************************/
+/* Square root functions for STACK */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* 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/2020070100/maxima/inequalities.mac b/stack/2020070100/maxima/inequalities.mac
new file mode 100644
index 0000000..4455ae9
--- /dev/null
+++ b/stack/2020070100/maxima/inequalities.mac
@@ -0,0 +1,306 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* 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, <chris@sangwin.com> */
+/* 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],
+ 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. */
+ ev(expand(ex/abs(numerical_coeff(ex))), simp)
+)$
+
+/* 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<x or x<a: a syntactic transformation. */
+inequality_disp(ex) := block([ex2, v],
+ if not(linear_inequalityp(ex)) then return(ex),
+ ex2:ineqprepare(ex),
+ v:first(listofvars(ex2)),
+ if equal(coeff(lhs(ex2), v), 1) then return(rev_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ if equal(coeff(lhs(ex2), v), -1) then return(neg_ineq(subst(op(ex2), "=", first(solve(lhs(ex2), v))))),
+ return(ex)
+)$
+
+/* Reverses the inequality: purely syntactic. */
+rev_ineq(ex):=block(
+ 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)),
+ 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)<lhs(ex)),
+ if op(ex)=">=" then return(rhs(ex)<=lhs(ex)),
+ return(apply(op(ex), map(make_less_ineq, args(ex))))
+)$
+
+/* Used to checks if we have the wrong inequality. */
+neg_ineq(ex):=block(
+ 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)
+)$
+
+/* 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<?, x<=?. */
+ exg:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = 1))),
+ exl:sublist(ex, lambda([ex2], is(coeff(lhs(ex2), first(listofvars(ex2))) = -1))),
+ /* Separate into solution and operator. */
+ exg:single_linear_ineq_reduce_h(exg, first(exo), true),
+ exl:single_linear_ineq_reduce_h(exl, second(exo), false),
+ append(exg, exl)
+)$
+
+/* Take a list of linear inequalities of the same sign, in a single variable, and an operator, min/max.
+ Return the single equivalent inequality.
+*/
+single_linear_ineq_reduce_h(exl, exo, odr):=block([m1,m2,m3,exg],
+ if exl=[] then return([]),
+ if not(is(exo = max) or is(exo = min)) then error("single_linear_ineq_reduce_h expects second argument to be max or min."),
+ exg:maplist(lambda([ex2],[rhs(first(solve(lhs(ex2)))), op(ex2)]), exl),
+ m1:apply(exo, maplist(first,exg)),
+ m2:sublist(exg,lambda([ex2],is(m1=first(ex2)))),
+ /* Get list of operators. Used to sort out >, >= 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)),
+ /* 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),
+ 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/2020070100/maxima/intervals.mac b/stack/2020070100/maxima/intervals.mac
new file mode 100644
index 0000000..55ed26f
--- /dev/null
+++ b/stack/2020070100/maxima/intervals.mac
@@ -0,0 +1,929 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* A package for manipulating intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* Re-written, May 2020. Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* 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 then Ans:{}, /* Our interval is the empty set if y<x. */
+ if x=y then Ans:{x}, /* Simply the set {x} is x=y. */
+ Ans
+)$
+
+oo_num(x,y) := block([Ans],
+ Ans: 'oo(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf ), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y) and not(y=inf or y=-inf ), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+co_num(x,y) := block([Ans],
+ Ans: 'co(x,y),
+ if ev(not real_numberp(x), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev((not real_numberp(y) and not(y=inf or y=-inf)), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+oc_num(x,y) := block([Ans],
+ Ans: 'oc(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+/* Validate student's input. */
+
+/* Return a list of errors for a single connected component. */
+interval_validate_single_interval(ex) := block([ret, iop, il, ir],
+ ret:"",
+ if trivialintervalp(ex) then return(""),
+ if not(intervalp(ex)) then
+ return(StackAddFeedback("", "Interval_notinterval", stack_disp(ex, "i"))),
+ if not(is(length(args(ex))=2)) then
+ /* The tex functions only cope with two arguments, so we have to use a string here! */
+ return(StackAddFeedback("", "Interval_wrongnumargs", stack_disp(string(ex), "i"))),
+ iop:op(ex),
+ il:first(args(ex)),
+ ir:second(args(ex)),
+ if real_numberp(il) and real_numberp(ir) and is(ir<il) then
+ ret:StackAddFeedback(ret, "Interval_backwards", stack_disp(ex, "i"), stack_disp(apply(iop,[ir, il]), "i")),
+ return(ret)
+)$
+
+/* Validate a realset, mostly for student feedback, so no errors thrown. */
+interval_validate_realset(ex) := block(
+ if trivialintervalp(ex) then return(""),
+ if setp(ex) then return(""),
+ if intervalp(ex) then return(interval_validate_single_interval(ex)),
+ if safe_op(ex)="%union" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ if safe_op(ex)="%intersection" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ return(StackAddFeedback("", "Interval_illegal_entries", stack_disp(ex, "i")))
+)$
+
+cc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right]")
+)$
+texput(cc, cc_interval_tex)$
+
+/* Note, the mismatching square brackets play havoc with the PHP interface. */
+co_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right)")*/
+ concat("!LEFTSQ! ", tex1(a),",\\, ",tex1(b), "!RIGHTR!")
+)$
+texput(co, co_interval_tex)$
+
+oc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right]")*/
+ concat("!LEFTR! ", tex1(a),",\\, ",tex1(b), "!RIGHTSQ!")
+)$
+texput(oc, oc_interval_tex)$
+
+oo_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right)")
+)$
+texput(oo, oo_interval_tex)$
+
+realset_tex(ex) := block([a, b, c],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ c:ev(interval_complement(b), simp),
+ if safe_setp(c) then
+ concat("{", tex1(a), " \\not\\in {",tex1(c), "}}")
+ else
+ concat("{", tex1(a), " \\in {",tex1(b), "}}")
+)$
+texput(realset, realset_tex)$
+
+/* Returns True if p is an element of A. False, otherwise: */
+
+inintervalp(p, A) := block ([Ans, Args, x, y, Atemp, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ Ans:false,
+ if not ev(real_numberp(p), simp) then
+ error("intervals: ",p," should be a real number"),
+
+ if atom(A) then Ans:false
+ elseif op(A)=set then
+ (
+ Atemp:listify(A),
+ n:length(Atemp),
+ while i<(n+1) do
+ (
+ if p=Atemp[i] then Ans:true,
+ i:i+1 )
+ )
+ elseif not( op(A)="[" ) then
+ (
+ Args:args(A),
+ x:first(Args),
+ y:last(Args),
+ if op(A)=cc then
+ (
+ if (p>=x and p<=y) then Ans:true
+ ),
+ if op(A)=oo then
+ (
+ if (p>x and p<y) then Ans:true
+ ),
+ if op(A)=co then
+ (
+ if (p>=x and p<y) then Ans:true
+ ),
+ if op(A)=oc then
+ (
+ if (p>x and p<=y) then Ans:true
+ )
+ )
+ elseif op(A)="[" then
+ (
+ n:length(A),
+ while j<n+1 do
+ (
+ Atemp:A[j],
+ Ans:inintervalp(p,Atemp),
+ if Ans=false then j:j+1 else j:n+1
+ )
+ )
+ else error("intervals: the interval, ",A,", is not of a recognised form"),
+ Ans
+)$
+
+intervalp(X) := block([A:X, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1)],
+ if atom(A) then return(false),
+
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+ if (op(A)=cc or op(A)=oo or op(A)=co or op(A)=oc) then return(true),
+ false
+)$
+
+realsetp(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(all_listp(real_numberp, args(ex))),
+ if intervalp(ex) then return(all_listp(real_numberp, args(ex))),
+ if op(ex)=%union then return(all_listp(realsetp, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realsetp, args(ex))),
+ return(false)
+)$
+
+/* Does not require all numbers to be actual real numbers. */
+realset_soft_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(realset_soft_p, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realset_soft_p, args(ex))),
+ return(false)
+)$
+
+/* Only looks at the very top level, used for validation */
+realset_surface_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(true),
+ if op(ex)=%intersection then return(true),
+ return(false)
+)$
+
+/* Make a real set, taking edge cases into account. This is also a top level function to convert true/false into all/none. */
+realsetmake(v, ex) := block(
+ if is(ex=false) then return(none),
+ if is(ex={}) then return(none),
+ if is(ex=%union()) then return(none),
+ if is(ex=%intersection()) then return(none),
+ if is(ex=true) then return(all),
+ if is(ex=all) or is(ex=none) or is(ex=unknown) then return(ex),
+ if atom(ex) then return(ex),
+ if is(safe_op(ex)="realset") then return(ex),
+ return(realset(v, ex))
+)$
+
+/* Predicate to remove trivial cases like oo(a,a) and co(-inf, -inf). */
+trivialintervalp(ex) := block(
+ if is(ex=all) or is(ex=none) then return(true),
+ if safe_setp(ex) and ex={} then return(true),
+ if not(intervalp(ex)) then return(false),
+ if safe_op(ex)="oo" and first(ex)=second(ex) then return(true),
+ if first(ex)=inf then return(true),
+ if second(ex)=-inf then return(true),
+ return(false)
+)$
+
+/* Return the number of separate connected components. */
+interval_count_components(ex) := block(
+ if not(realsetp(ex)) then error("interval_count_components"),
+ if ex=all then return(1),
+ if trivialintervalp(ex) then return(0),
+ if intervalp(ex) then return(1),
+ if setp(ex) then return(cardinality(ex)),
+ ev(apply("+", map(interval_count_components, args(ex))), simp)
+)$
+
+interval_simple_union(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then
+ Ans:B
+ elseif atom(B) then
+ Ans:A
+ elseif safe_setp(A) then (
+ if safe_setp(B) then
+ Ans:union(A,B)
+ else (
+ Args1:args(B),
+ x1:first(Args1),
+ y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if (Aset[i]<x1 or Aset[i]>y1) 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:i+1
+ ),
+ 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]<x1 or 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:i+1
+ ),
+ 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:false,
+ if first(Args1)=first(Args2) then (
+ if ( op(A)=co or op(A)=cc ) then
+ swap:false
+ elseif ( op(B)=co or op(B)=cc ) then
+ swap:true
+ else swap:false
+ ),
+ 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 (x2<y1 and y2>y1) 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 (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:interval_simple_union( A , {y2} )
+ else
+ Ans:A
+ ),
+ if (x2<y1 and y2<y1) then
+ Ans:A,
+ if x2=y1 then (
+ if ( (op(A)=co or op(A)=oo) and (op(B)=oo or op(B)=oc) ) then
+ Ans:[A,B]
+ else (
+ 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)
+ )
+ )
+ )
+ )
+ ),
+ Ans
+)$
+
+
+/* Finds the intersection of two "simple" real sets. */
+interval_simple_intersect(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, lopen:false, ropen:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+ if safe_setp(A) and safe_setp(B) then return(intersect(A,B)),
+ /* A & B are not both sets. */
+ if safe_setp(B) then (
+ A:Y,
+ B:X
+ ),
+ if safe_setp(A) then (
+ Args1:args(B),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if inintervalp(Aset[i],B) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 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:false,
+ if first(Args1)=first(Args2) then (
+ if (op(A)=co or op(A)=cc) then (
+ swap:false
+ ) elseif (op(B)=co or op(B)=cc ) then (
+ swap:true
+ ) else (
+ swap:false
+ )
+ ),
+ if is(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 (x2<y1 and y2>y1) 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 (x2<y1 and y2<y1) then
+ Ans:B,
+ if (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=oo) then lopen:true,
+ if (op(B)=oo or op(B)=co or op(A)=oo or op(A)=co) then ropen:true,
+ if (lopen and ropen) then Ans:oo(x2,y1),
+ if (lopen and not ropen) then Ans:oc(x2,y1),
+ if (not lopen and ropen) then Ans:co(x2,y1),
+ if (not lopen and not ropen) then Ans:cc(x2,y1)
+ ),
+ if x2=y1 then (
+ if ((op(A)=cc or op(A)=oc) and (op(B)=co or op(B)=cc)) then
+ Ans:{x2}
+ else
+ Ans:{}
+ ),
+ Ans
+)$
+
+interval_disjointp(A, B) := if interval_simple_intersect(A, B)={} then true else false$
+
+/* Is the ex1 contained within the real set ex2? */
+interval_subsetp(ex1, ex2) := block(
+ if not(realsetp(ex1)) then error("interval_subsetp expects its first argument to be a real set."),
+ if not(realsetp(ex2)) then error("interval_subsetp expects its second argument to be a real set."),
+ if interval_intersect(ex1, ex2) = ex1 then true else false
+)$
+
+/* Is the simple interval ex a explicitly a subinterval of EX? */
+interval_containsp(ex, EX) := block(
+ if not(intervalp(ex)) then error("interval_containsp expects its first argument to be a simple interval."),
+ if not(realsetp(EX)) then error("interval_containsp expects its second argument to be a real set."),
+ if is(ex=EX) then return(true),
+ if not(safe_op(EX)="%union" or safe_op(EX)="%intersection") then return(false),
+ if elementp(ex,setify(args(EX))) then return(true),
+ return(false)
+)$
+
+/* Top level intersection function which takes real sets, such as %unions. */
+interval_intersect(X,Y) := block([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if safe_op(A)="%intersection" then A:interval_intersect_list(args(A)),
+ if safe_op(B)="%intersection" then B:interval_intersect_list(args(B)),
+
+ if is(A=all) then return(B),
+ if is(B=all) then return(A),
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if not(listp(A)) and not(listp(B)) then return(interval_simple_intersect(A,B)),
+
+ /* Ensure we have lists to deal with, by making them lists of one element if needed. */
+ if not(listp(A)) then (temp:[], A:cons(A,temp) ),
+ if not(listp(B)) then (temp:[], B:cons(B,temp) ),
+
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (
+ A:A[1],
+ B:B[1],
+ return(interval_simple_intersect(A,B))
+ ) else (
+ while i<m+1 do (
+ while j<n+1 do (
+ temp:interval_simple_intersect(A[i], B[j]),
+ if not atom(temp) then (
+ Ans:append(Ans, [temp])
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ ),
+ if listp(Ans) then (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ ),
+ interval_tidy(Ans)
+)$
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+interval_intersect_list(X) :=
+ block ( [A:X, Ans, n, i, simp],
+ simp:true,
+ if X=[] then return({}),
+ n:length(A),
+ if n=1 then return(first(A)),
+ Ans:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ Ans:interval_intersect(Ans, A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+interval_intersect_nary([X]) := interval_intersect_list(X)$
+
+/* Given intervals, returns the same intervals but in ascending order of the first element in the interval. */
+interval_sort(X) := block([A:X, Ans:[], x, n, i],
+ if safe_op(X) = "%union" then A:args(X),
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do block(
+ if is(first(A[i]) < first(x)) then x:A[i],
+ i:ev(i+1,simp)
+ ),
+ Ans:append(Ans,[x]),
+ A:delete(x, A, 1),
+ n:ev(n-1, simp)
+ ),
+ /* %union does things to its arguments like moving -inf to the right with simp:true. */
+ /* Return a list to avoid killing the order here. */
+ Ans
+);
+
+/* Given a union of disjoint intervals,
+ checks whether any intervals are connected, and if so, joins them up and returns the ammended union. */
+interval_connect(X) := block([Ans, n, x, y, i:1],
+ if not(op(X)=%union or listp(X)) then error("interval_connect requires a %union or list of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ i:ev(i,simp),
+ if last( Ans[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:i+1
+ ),
+ 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],
+ if atom(X) then return(Ans:phi),
+ if listp(X) then X:apply(%union, X),
+ X:ev(X, %intersection=interval_intersect_nary),
+
+ if not(op(X)=%union or listp(X)) then (
+ Ans:X
+ ) else (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<ev(n+1, simp) do (
+ i:ev(i,simp),
+ if safe_setp(A[i]) then (
+ setpart:union(setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ) else if trivialintervalp(A[i]) then (
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ),
+ i:ev(i+1, simp)
+ ),
+ A:interval_sort(A),
+ if is(length(A)>1) 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
+ ),
+ 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 i<n+1 do
+ (
+ if length(setpart)>0 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:i+1
+ )
+ )
+ else Ans:A,
+ Ans
+)$
+
+/* Return the set complement of a real set. */
+interval_complement(X):= block([A:X, Ans:[], x, y, 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 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<n do (
+ temp:oo( A[i], A[i+1] ),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ i:i+1
+ ),
+ temp:oo(A[n], inf),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ apply(%union, Ans)
+)$
+
+/* Turns a single variable system over the reals in to a set of real numbers, together with insoluable bits (if any). */
+single_variable_solver_real(ex) := block([v, rs1, rs2],
+ if is(ex=false) then return(none),
+ if is(ex=true) then return(all),
+ if atom(ex) then return(ex),
+ v:listofvars(ex),
+ if is(length(v)=0) then block
+ (
+ if is(ratsimp(lhs(ex)-rhs(ex))=0) then
+ ex:all
+ else
+ ex:none
+ ),
+ if not(length(v)=1) then return(ex),
+ v:first(v),
+ ex:abs_replace_eq(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),
+
+ /* Notes,
+ (1) assume_pos automatically removes terms like v>=0 in the simplifier.
+ (2) we do need simplification here to reduce execution time.
+ */
+
+ if assume_pos then
+ ex:block([assume_pos:false], ev(single_variable_solver_real_rec(ex %and (v>=0), v), simp))
+ else
+ ex:ev(single_variable_solver_real_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),
+ rs1:realsetmake(v, rs1),
+ if is(rs1=none) then
+ ex:apply("%or", rs2)
+ else if is(rs1=all) then
+ ex:all
+ else
+ ex:realsetmake(v, rs1) %or apply("%or", rs2)
+ ),
+ if safe_op(ex)="%union" or safe_setp(ex) then
+ ex:realsetmake(v, ex),
+
+ return(ex)
+)$
+
+single_variable_solver_real_rec(ex, v) := block([r0, r1, r2],
+ if atom(ex) then return(ex),
+ if intervalp(ex) then return(ex),
+
+ if equationp(ex) then return(ev(equation_to_intervals(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], single_variable_solver_real_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)
+)$
+
+equation_to_intervals(ex, v) := block([sol0, sol1, sol2],
+ sol0: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),
+ sol1:flatten(setify(sol1)),
+ if is(length(sol2)=1) then
+ sol2:first(sol2)
+ else
+ sol2:apply("%or", sol2),
+ if emptyp(sol1) then
+ return(sol2),
+ return(sol1 %or sol2)
+)$
+
+/* Calculate the natural domain of a single-variable term. */
+natural_domain(ex) := block([v, ex2],
+ 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),
+ realsetmake(v, ex2)
+)$
+
+/* 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(single_variable_solver_real(first(args(ex))>=0)),
+ if safe_op(ex)="ln" or safe_op(ex)="log" or safe_op(ex)="lg" then
+ return(single_variable_solver_real(first(args(ex))>0)),
+ if safe_op(ex)="/" then
+ ex2:[natural_domain_rec(first(args(ex))), single_variable_solver_real((second(args(ex))>0) %or (second(args(ex))<0))]
+ else
+ 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),
+ ex2
+)$
diff --git a/stack/2020070100/maxima/noun_arith.lisp b/stack/2020070100/maxima/noun_arith.lisp
new file mode 100644
index 0000000..eff2e25
--- /dev/null
+++ b/stack/2020070100/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 $noun+ tex-mplus tex)
+(defprop $noun+ ("+") texsym)
+(defprop $noun+ 100. tex-lbp)
+(defprop $noun+ 100. tex-rbp)
+
+(defprop $noun- tex-prefix tex)
+(defprop $noun- ("-") texsym)
+(defprop $noun- 100. tex-rbp)
+(defprop $noun- 100. tex-lbp)
+
+(defprop $noun* tex-nary tex)
+(defprop $noun* "\\," texsym)
+(defprop $noun* 120. tex-lbp)
+(defprop $noun* 120. tex-rbp)
+
+(defprop $noun/ tex-mquotient tex)
+(defprop $noun/ 122. tex-lbp) ;;dunno about this
+(defprop $noun/ 123. tex-rbp)
+
+(defprop $noun^ tex-mexpt tex)
+(defprop $noun^ 140. tex-lbp)
+(defprop $noun^ 139. tex-rbp)
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+(defprop $nounand 65. tex-lbp)
+(defprop $nounand 65. tex-rbp)
+;;(defprop mand ("\\land ") texsym)
+(defprop mand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+(defprop $nounor 61. tex-lbp)
+(defprop $nounor 61. tex-rbp)
+;;(defprop mor ("\\lor ") texsym)
+(defprop mor ("\\,{\\mbox{ !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/2020070100/maxima/rtest_assessment_simpboth.mac b/stack/2020070100/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000..784cb48
--- /dev/null
+++ b/stack/2020070100/maxima/rtest_assessment_simpboth.mac
@@ -0,0 +1,373 @@
+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'); ",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! ); ",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'); ",false]$
+irred_Q(9-3*x+3*x^5,x);
+[false,"stack_trans('irred_Q_commonint'); ",true]$
+
+irred_power_Qp(2,x);
+true$
+irred_power_Qp((x-1)^2,x);
+true$
+irred_power_Qp((3*x-6)^4,x);
+true$
+irred_power_Qp(x^2-1,x);
+false$
+irred_power_Qp(3*x-6*x^3+3*x^6,x);
+false$
+irred_power_Qp(9-3*x+3*x^5,x);
+true$
+
+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{False}\\)"$
+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]$
+
diff --git a/stack/2020070100/maxima/rtest_assessment_simpfalse.mac b/stack/2020070100/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000..e4228b9
--- /dev/null
+++ b/stack/2020070100/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*(1/x+1/1)$
+buggy_pow( 3*(x+1)^-2 );
+3*(1/x^2+1/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/2020070100/maxima/rtest_assessment_simptrue.mac b/stack/2020070100/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000..6f71fbf
--- /dev/null
+++ b/stack/2020070100/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/2020070100/maxima/rtest_elementary.mac b/stack/2020070100/maxima/rtest_elementary.mac
new file mode 100644
index 0000000..f0034a8
--- /dev/null
+++ b/stack/2020070100/maxima/rtest_elementary.mac
@@ -0,0 +1,179 @@
+zeroAdd(x);
+x$
+zeroAdd(0+x);
+x$
+zeroAdd(0+0+x);
+0+x$
+zeroAdd(x+0);
+x+0$
+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);
+x*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*1$
+oneMul(1^x);
+1^x$
+oneMul(x^1);
+x^1$
+oneMul(1*1*x);
+1*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$
+
+zPow(1);
+1$
+zPow(x^0);
+1$
+zPow(0^x);
+0^x$
+zPow(0^0);
+0^0$
+zPow(1+x);
+1+x$
+
+unaryAdd(x);
+x$
+unaryAdd("+"(x));
+x$
+unaryAdd("*"(x));
+"*"(x)$
+unaryAdd("+"(x,y));
+x+y$
+
+unaryMul("*"(x));
+x$
+unaryMul("*"(x,y));
+x*y$
+
+
+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$
+
+negNeg(x);
+x$
+negNeg(-x);
+-x$
+negNeg(-(-x));
+x$
+
+negZero(-x);
+-x$
+negZero(-0);
+0$
+negZero("-"(0));
+0$
+
+negDef(a-a);
+0$
+negDef(a+b-a);
+b$
+negDef(a-a-a);
+-a$
+negDef(a-a+b-b);
+0$
+
+negDistAdd(-(a+b));
+-a-b$
+
+intAdd(1+2);
+3$
+intAdd(1+x+2);
+x+3$
+
+intMul(2*3);
+6$
+intMul(2*x*3);
+6*x$
+
+intPow(2^3);
+8$
+intPow(2^x);
+2^x$
+intPow(0^0);
+0^0;
+
+
+
+
+
diff --git a/stack/2020070100/maxima/rtest_experimental.mac b/stack/2020070100/maxima/rtest_experimental.mac
new file mode 100644
index 0000000..e69de29
diff --git a/stack/2020070100/maxima/rtest_inequalities.mac b/stack/2020070100/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000..2498d27
--- /dev/null
+++ b/stack/2020070100/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)$
+1<x$
+
+inequality_disp(x-1<=%pi)$
+x<=1+%pi$
+
+inequality_disp(x>1);
+1<x$
+
+inequality_disp(2*x>%pi);
+%pi/2<x$
+
+inequality_disp(x>=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^2<x);
+x^2>x;
+
+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<x;
+
+rev_ineq(x>=6);
+6<=x;
+
+rev_ineq(x^2<x);
+x>x^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 6<x));
+x>6 and y>2$
+
+ineq_rem_redundant(1<x and x<%pi and x<20);
+x>1 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/2020070100/maxima/rtest_intervals.mac b/stack/2020070100/maxima/rtest_intervals.mac
new file mode 100644
index 0000000..b540ba0
--- /dev/null
+++ b/stack/2020070100/maxima/rtest_intervals.mac
@@ -0,0 +1,161 @@
+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/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(-1,-1/2),oo(-1/2,inf),oo(-inf,-1)))$
+
+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((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)))$
+
+single_variable_solver_real(x^2-4>0);
+realset(x,%union(oo(2,inf),oo(-inf,-2)))$
+
+single_variable_solver_real(2*x/abs(x-1)<1);
+(1-(2*x)/(x-1) > 0) %or ((2*x)/(x-1)+1 > 0)$
+
+single_variable_solver_real(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),{3},oc(-inf,0))$
+
+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/2020070100/maxima/sandbox.wxm b/stack/2020070100/maxima/sandbox.wxm
new file mode 100644
index 0000000..bd88b25
--- /dev/null
+++ b/stack/2020070100/maxima/sandbox.wxm
@@ -0,0 +1,85 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 13.04.2 ] */
+
+/* [wxMaxima: title start ]
+STACK Sandbox
+ [wxMaxima: title end ] */
+
+/* [wxMaxima: comment start ]
+This document loads the extra files needed for STACK.
+See https://github.com/maths/moodle-qtype_stack
+
+1. Set your operation system in the variable maximaplatform. For Windows set it to "win".
+2. If needed, set the stacklocation variable to the location of this sandbox file and the needed maxima and lisp files.
+3. 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 ] */
+/* No trailing slash. */
+maximaplatform:"linux"$
+stacklocation:"."$
+stacktmplocation:"/tmp"$
+
+/* For MS platforms you normally need to explicitly set the path.
+ Use the forward slash as a directory seperator.
+ You have cloned your code into c:/tmp/stackroot
+*/
+/*
+maximaplatform:"win"$
+stacklocation:"c:/tmp/stackroot/stack"$
+*/
+
+
+/****************************************************
+ 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, "/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/maxima/###.{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)$
+
+STACK_SETUP(ex):=block(
+ MAXIMA_VERSION_NUM_EXPECTED:41.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:"del",
+ GNUPLOT_CMD:"C:\\bin\\moodle\\server\\moodledata\\stack\\wgnuplot.exe",
+ MAXIMA_VERSION_EXPECTED:"5.42.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, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, 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, 0.01*Sv, m^2/s^2, 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{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}"],
+ stack_unit_other_unit_code:[min, amu, u, mmHg, bar, cc, gal, mbar, atm, torr, rev, deg, rpm, K, day, year, in, ft, mi],
+ stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 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), K, 86400*s, 3.156e7*s, in, 12*in, 5280*12*in],
+ stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{K}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{mi}"],
+ true)$
+/* Load the main libraries. */
+load("stackmaxima.mac")$
+load("stats")$
+load("distrib")$
+load("descriptive")$
+print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$
+/* [wxMaxima: input end ] */
+
+/* [wxMaxima: input start ] */
+/* Optional but useful. */
+display2d:true;
+simp:false;
+debug:true;
+/* [wxMaxima: input end ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2020070100/maxima/stack_logic.lisp b/stack/2020070100/maxima/stack_logic.lisp
new file mode 100644
index 0000000..2a1e162
--- /dev/null
+++ b/stack/2020070100/maxima/stack_logic.lisp
@@ -0,0 +1,678 @@
+#|
+; logic.mac--Logic algebra package for Maxima CAS.
+; Copyright (c) 2008--2009 Alexey Beshenov <al@beshenov.ru>.
+;
+; 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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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
+;
+;
+; TODO: 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/2020070100/maxima/stackmaxima.mac b/stack/2020070100/maxima/stackmaxima.mac
new file mode 100644
index 0000000..d1717dd
--- /dev/null
+++ b/stack/2020070100/maxima/stackmaxima.mac
@@ -0,0 +1,3146 @@
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/* ********************************** */
+/* 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,
+ /* 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,
+
+ 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);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* Corresponds to current student expectations */
+alias(cosech,csch); /* Corresponds to current student expectations */
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+
+/* TODO: 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("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
+)$
+
+/* ********************************** */
+/* Load STACK packages */
+/* ********************************** */
+
+load("assessment.mac");
+load("inequalities.mac");
+load("intervals.mac");
+load("stackunits.mac");
+load("stacktex.lisp");
+load("stackstrings.mac");
+load("sregex");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+load("casanswertest.mac");
+load("errortostring.lisp");
+
+/* Breaks on older versions of Maxima. */
+if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+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 = "blank" then texput("*", "\\, ", nary)
+);
+
+make_logic(OPT_LOGIC) := block(
+ if OPT_LOGIC = "lang" then block(
+ texput("and", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("nounand", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("or", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nounor", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nand", "\\,{\\mbox{ !NAND! }}\\, ", nary),
+ texput("nor", "\\,{\\mbox{ !NOR! }}\\, ", nary),
+ texput("xor", "\\,{\\mbox{ !XOR! }}\\, ", nary),
+ texput("xnor", "\\,{\\mbox{ !XNOR! }}\\, ", nary),
+ texput("implies", "\\,{\\mbox{ !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)
+)$
+
+/* Options for cos^(-1), acos or arccos. */
+/* There is a bug in texput which prevents us from avoiding a "load" here. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then load("cos-1.lisp"),
+ if OPT_ACOS = "arccos" then load("arccos.lisp"),
+ if OPT_ACOS = "acos" then load("acos.lisp")
+);
+
+/* 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);
+
+/* ****************************************************** */
+/* 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(
+ 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)
+)$
+
+/* Make a random selection of n different items from the list ex. */
+/* CJS, 7/6/2016 */
+rand_selection(ex, n) := block(
+ if not(listp(ex)) then (
+ error("rand_selection error: first argument must be a list."),
+ 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."),
+ 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)
+)$
+
+/* 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)<numcor then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqn: you have asked for more correct responses than are supplied in the list!"),
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ return([ta, version])
+)$
+
+/* Helper function for constructing MCQ arrays with auto-generated alphabetic labels. Students choose the labels. */
+multiselqnalpha([exs]):=block([corbase, numcor, wrongbase, numwrong, dispflag, ta1, ta2, ta3, talab, ta, version],
+ if length(exs)<4 then error("multiselqnalpha must have at least four arguments."),
+ corbase:first(exs),
+ numcor:second(exs),
+ wrongbase:third(exs),
+ numwrong:fourth(exs),
+ dispflag:"id",
+ if length(exs)>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)<numcor then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta3: random_permutation(append(ta1, ta2)),
+ /* Add in a slightly different display here. */
+ talab: ev(makelist(sconcat("(",ascii(96+i),")"), i, 1, length(ta3)), simp),
+ ta:zip_with(lambda([ex1, ex2], [ex1, ex2[2], sconcat("<b>", ex1, "</b> ",
+ 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)<numcor then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqndisplay: you have asked for more correct responses than are supplied in the list!"),
+ /* */
+ corbase: zip_with("[", ev(makelist(k,k,1,length(corbase)),simp), corbase),
+ wrongbase: zip_with("[", ev(makelist(k,k,1+length(corbase),1+length(corbase)+length(wrongbase)),simp), wrongbase),
+ ta1: maplist(lambda([ex], [first(ex), true, second(ex)]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [first(ex), false, second(ex)]), rand_selection(wrongbase, numwrong)),
+ ta: random_permutation(append(ta1, ta2)),
+ version: map(first, ta),
+ /* */
+ return([ta, version])
+)$
+
+/* Helper functions for MCQ arrays. */
+mcq_correct(ta):=block(
+ if not(listp(ta)) then error("mcq_correct: first argument must be a list, but was passed: ", string(ta)),
+ if not(all_listp(listp, ta)) then error("mcq_correct: 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_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)))))
+)$
+
+/* ********************************** */
+/* 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]])$
+
+/* 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],
+ %_tmp:[[_k, stack_dispvalue(_v)]],
+ if listp(%_tmp) then _DVALUES:append(_DVALUES,%_tmp),
+ 0)$
+_CS2dvv(_k,_v) := (_CS2v(_k,_v),_CS2dv(_k,_v),0)$
+
+/* ********************************** */
+/* Display */
+/* ********************************** */
+/* expr - expression to be displayed */
+/* m - mode, either */
+/* "i" inline or */
+/* "d" for displayed, or */
+/* "" for no delimiters. */
+/* ********************************** */
+
+stack_disp(expr, exprm) := block([str:"", expru],
+ /* LaTeX display */
+ if OPT_OUTPUT = "LaTeX" then
+ if not(ev(elementp(exprm, {"", "i", "d", "id"}), simp)) then print(concat("ERROR: illegal delimiter option found: ", exprm)),
+ /* Fine tune display, e.g. sort out display of atoms like theta0. */
+ expru: expr,
+ if not(stack_disp_control_structurep(expr)) then block(
+ expru: unary_minus_sort(expr),
+ expru: stack_disp_sub_script(expru)),
+
+ str: block([expstr, offset, ld, rd],
+ ld: "",
+ rd: "",
+ if exprm = "i" then block(ld: "\\(", rd:"\\)"),
+ if exprm = "id" then block(ld: "\\(\\displaystyle ", rd:"\\)"),
+ if exprm = "d" then block(ld: "\\[", rd:"\\]"),
+ mminusbp100(true),
+ expstr: tex(expru, false),
+ mminusbp120(true),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* String display */
+ if OPT_OUTPUT = "String" then str: string(expr),
+ /* If no correct options have been set. */
+ if str = "" then str:string(expr),
+ return(str)
+)$
+/* This function was renamed to improve the consistency of the coding style. */
+/* We continue to support the old name, since question authors may have used */
+/* it, even though that was not recommended practice. */
+alias(StackDISP, stack_disp)$
+
+/* If an expression contains these control structures then we don't fine-tune the display. */
+stack_disp_control_structurep(ex) := not(freeof(?mdoin, ?mdo, ?mcond, catch, throw, ":=", lambda, setelmx, ex))$
+
+stack_disp_strip_dollars(ex) := block(
+ if ?subseq(ex, 0, 2) = "$$" then
+ ex:?subseq(ex, 2, ev(?length(ex)-3, simp))
+ /* Remove \begin{verbatim}'s from Maxima's TEX command */
+ else if ?length(ex) > 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";
+?texnumformat(x) := if ev(floatnump(x),simp) then
+ ev(printf(false, stackfltfmt, x), simp) else if ev(integerp(x),simp) then (
+ if (is(stackintfmt="~r") or is(stackintfmt="~:r")) then
+ sconcat("\\mbox{",ev(printf(false, stackintfmt, x), simp),"}")
+ else
+ ev(printf(false, stackintfmt, x), simp)
+ ) else
+ string(x);
+/* 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),
+ 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..... */
+
+/* ******************************************* */
+/* Validate an expression */
+/* ******************************************* */
+
+/* List of variables, without some specific tokens in. */
+stack_validate_listofvars(ex) := block([lvars],
+ lvars:ev(setify(listofvars(ex)), simp),
+ lvars:ev(setdifference(lvars,{null, QMCHAR, EMPTYANSWER}), simp),
+ lvars:ev(sort(listify(lvars)), simp)
+)$
+
+stack_validate(expr, LowestTerms, TAns) := block([simp:false, exs, SameType, 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"),
+ 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 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, Equiv, fltfmt) := block([simp:false, exs, fvs, fvs1, fvs2],
+ /* If we have a float format, then use it. */
+ if not(is(fltfmt=false)) then
+ stackfltfmt:fltfmt,
+ /* 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 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])
+)$
+
+/* *************************************/
+/* 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],
+ 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(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ 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],
+ /* 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. */
+ tn: string(absolute_real_time()),
+ filename:concat("stackplot","-",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("<img src='", URL_BASE, filename, ".", PLOT_TERMINAL, "' alt='", str_to_html(alttext), "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class='stack_plot'>", ufn, "</div>"),
+ ufn: concat(" <html>", ufn, "</html> "),
+ /* 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]])
+ ),
+ /* Add in the command for the grid. */
+ if plotgrid2d and MAXIMA_VERSION_NUM>34 then
+ ral: append(ral, [grid2d]),
+ /* Note, the axes option in Maxima doesn't seem to work.... */
+ 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),
+ 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. */
+ 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)
+)$
+
+/* ********************************** */
+/* Numerical operations */
+/* ********************************** */
+
+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_displaydp(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(TA) then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_number"))
+ else
+ if numtype = "ABSOLUTE" then
+ return([true, numabsolutep(SA, SB, tol), "", ""])
+ else
+ return([true, numrelativep(SA, SB, tol), "", ""]),
+
+ 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<ta-tol, then f1<0. */
+ /* if abs(sa-ta)<abs(tol), then f2<0. */
+ /* We appear to need to calulate f1 & f2 as variables, */
+ /* otherwise Maxima's is complains "undefined". Odd... */
+ sa:first(sal),
+ ta:first(tal),
+ if type="ABSOLUTE" then
+ (f1:ev(float(sa-ta+tol),simp),
+ f2:ev(float(abs(sa-ta)-abs(tol)), simp))
+ else
+ (f1:ev(float(sa-ta*(1-tol)),simp),
+ f2:ev(float(abs(sa-ta)-abs(ta*tol)), simp)),
+ /*print([sa,ta,f1,f2]),*/
+ if is(f1<0) then return(num_compare_helper(rest(sal), tal, missing, append([sa], excessive), tol, type)),
+ if is(f2<0)
+ then return(num_compare_helper(rest(sal), rest(tal), missing, excessive, tol, type)),
+ return(num_compare_helper(sal, rest(tal), append([ta], missing), excessive, tol, type))
+)$
+
+ATNumSigFigs(SA, SB, SO) := block([simp, Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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("","ATNumSigFigs_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+ if listp(ol) then
+ if length(ol)#2 then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_list_wrong_length"), StackAddFeedback("", "TEST_FAILED_Q")]))
+ else
+ (nsf:ol[1], asf:ol[2])
+ else (nsf:ol, asf:ol),
+ if ev(not(integerp(nsf) and integerp(asf)), simp) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* Remove ephemeral forms from teacher's answers. */
+ SB:remove_displaydp(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)
+)$
+
+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)
+ )$
+
+/* ********************************** */
+/* 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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],
+ /* Turn on simplification and error catch */
+ if is(_EC(errcatch(SA:ev(SA, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_SAns"), ""]),
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ if is(_EC(errcatch(SB:ev(SB, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SA, SB),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ 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)
+)$
+
+/* 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,
+ /* 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 algebraic_equivalence(SA, SB) then
+ RawMark:true
+ else if algebraic_equivalence(exdowncase(SA), exdowncase(SB)) then
+ AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase"),
+ ret:[Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+ )$
+
+/* 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,
+
+ /* Trap edge cases. */
+ 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 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", ""]),
+ 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 single_variable_solver_real(SA)=single_variable_solver_real(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(
+ 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(
+ /* TODO: 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)<length(SA)) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_duplicates"),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_duplicates")
+ ),
+
+ /* We check the simplified sets. */
+ if (subsetp(SAsimp, SBsimp) and subsetp(SBsimp, SAsimp)) then
+ return([true, true, AnswerNote, FeedBack]),
+
+ /* Can we give feedback on which are wrong ? */
+ if not(emptyp(setdifference(SAsimp, SBsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_wrongentries", stack_disp(setdifference(SAsimp, SBsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_wrongentries")
+ ),
+ if not(emptyp(setdifference(SBsimp, SAsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_missingentries", stack_disp(setdifference(SBsimp, SAsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_missingentries")
+ ),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+/* We don't put in boolean_form, or noun_logic_remove here because that breaks (pre-existing) inequalities and equations. */
+ATSets_prepare(S) := ev(map(lambda([ex], ineqprepare(trigreduce(ex)) ), S), simp)$
+
+
+/* Maxima regular expressions. */
+ATSRegExp(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, patmatched],
+ 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("","ATSRegExp_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATSRegExp_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SA_not_string")),
+
+ patmatched:regex_match(SBsimp, SAsimp),
+
+ if listp(patmatched) then
+ return([true, true, StackAddNote("", sconcat("ATSRegExp: ", string(patmatched))), FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+/* 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]])
+)$
+
+
+/* A general, all purpose answer test which checks things are of the
+ same "type". Based upon the results of AtAlgEquivfun(SA,SB)
+*/
+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(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("", "ATSubstEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SB:errcatch(ev(SB, simp, nouns)),
+ if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_TAns"), ""]),
+ SB:SB[1],
+ /* 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),
+ 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(single_variable_solver_real(SA), simp),
+ SBP:ev(single_variable_solver_real(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],
+
+ 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(sa,sb) then
+ (RawMark:true, AnswerNote:"")
+ else
+ (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")),
+
+ if SA=SB then
+ return([Validity, true, StackAddNote("","ATCASEqual_true"), FeedBack]),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(SA,SB),
+ if ret[2]=false then
+ return([true, false, StackAddNote("ATCASEqual ", StackTrimNote(ret[3])), ret[4]]),
+ ret:block([simp:true, ret], ATAlgEquivfun(SA, SB)),
+ 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 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],
+ deg:ev(hipow(expand(p),v),simp),
+ /* Now perform the general test */
+ cl:ev(map(second,coeff_list_nz(expand(p),v)),simp),
+ /* 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 deg=0 then ret:[true,"",false],
+ /* Special situation for the linear case to avoid strange results */
+ if 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 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)
+);
+
+/* Is p a power of an irreducible term in v, over the rationals Q, disregarding the special case of a numerical factor? */
+/* Only used by ATPartFrac */
+/* Returns true/false */
+irred_power_Qp(p,v) := block([ret],
+ if safe_op(p)="^" then ret:irred_Q(first(args(p)),v) else ret:irred_Q(p,v),
+ if third(ret) then true else first(ret)
+);
+
+/* Picks apart an expression p of v, and gives some feedback */
+/* on why this is not a factored expression */
+FacForm_UnPick(SA, SO) := block([negdistrib, PARTSWITCH, fb, kloop, irred, res],
+ negdistrib:false,
+ partswitch:true,
+ fb:"",
+ res:true,
+ if atom(SA) then return([true, ""]),
+ if safe_op(SA) = "-" then SA:part(SA,1),
+ 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 atom(SB) then return([true,""]),
+ if safe_op(SB) = "-" then SA:part(SB,1),
+ if op(SB) = "+" then return(irred_Q(SB, SO)),
+ if 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? */
+/* Assumes all coefficients are integers. */
+
+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],
+ if errcatch(deg:hipow(expand(SA), SO)) = [] then block(
+ val: false,
+ rawmk: false,
+ ansnote: StackAddNote("", "ATFacForm_error_degreeSA"),
+ fb: StackAddFeedback("", "ATFacForm_error_degreeSA")
+ ),
+ aequiv:algebraic_equivalence(SA, SB),
+ SA:flatten(SA),
+ /* An integer answer is always correct. */
+ if (integerp(SA)) then
+ if (SA=SB) then
+ ansnote: StackAddNote("", "ATFacForm_int_true")
+ else block(
+ rawmk: false,
+ ansnote: StackAddNote("", "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 ( /* We need to provide some feedback, if possible */
+ ansnote:StackAddNote(ansnote, "ATFacForm_isfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_isfactored")
+ )
+ else
+ (up:FacForm_UnPick(SA, SO) ),
+ if (up[1]=false) then (
+ rawmk: false,
+ ansnote:StackAddNote(ansnote, "ATFacForm_notfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_notfactored"),
+ fb:concat(fb, up[2])
+ )
+ else
+ (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. */
+PartFracfun(sExpr, tExpr, wrt) := block([val, rawmk, ansnote, fb],
+ 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")
+ ),
+ /* ... with the degree(num)<degree(den) */
+ if not all_listp(lambda([ex],if denom(ex)=1 then true else is(ev(hipow(expand(num(ex)),wrt)<hipow(expand(denom(ex)),wrt),simp))),list) then
+ block(
+ rawmk: false,
+ ansnote:StackAddNote("","ATPartFrac_false_degree")
+ ),
+ /* We need to check that each denominator is the power of an irreducible factor */
+ /* Note the slight cludge to check if we have a numerical factor */
+ if not all_listp(lambda([ex],irred_power_Qp(denom(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)
+ )$
+
+/* ************************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, atoptions],
+ oldsimp:simp,
+ simp:false,
+ Validity:true, RawMark:false,
+ FeedBack:"", AnswerNote:"",
+ keepfloat:true,
+ /* Should we be fussy about the constant of integration? */
+ constint:true,
+ /* 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 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),
+ sbdisp:fourth(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, 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. */
+ATIntOptions(opts) := block([note, var, atopts, optdefaults],
+ note:"",
+ /* Add in default values for the options here. See ATIntOptionsHelper for details.*/
+ optdefaults:[true,[]],
+ if emptyp(opts) or not(is(length(opts)<4)) then return(["ATInt_STACKERROR_OptList", x, 0, true]),
+ var:first(opts),
+ atopts:ATIntOptionsHelper(rest(opts), optdefaults),
+ return(append([note, var], atopts))
+)$
+
+/* The second argument to this function is a list of all options in a *known order*.
+ We recurse over the list updating these. We seed the function with defualt values.
+ Options currenty are as follows:
+ [NOCONST, spdisp]
+ where
+ NOCONST = true or false. Are we strict in requiring a constant of integration?
+ 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.
+*/
+ATIntOptionsHelper(in, out) := block(
+ if emptyp(in) then return(out),
+ if is(first(in)=NOCONST) then return(ATIntOptionsHelper(rest(in), append([false], rest(out)))),
+ return(ATIntOptionsHelper(rest(in), [first(out), first(in)]))
+)$
+
+Intfun(SA, SB, SBdisp, constint, 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:false, 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("", "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)$
+
+/* Slight hack to compile these functions and hence suppress warnings. */
+load(linearalgebra);
+
+/* Stack expects some output with the version number the output happens at */
+/* maximalocal.mac after additional library loading */
+stackmaximaversion:2020070100$
diff --git a/stack/2020070100/maxima/stackreporting.mac b/stack/2020070100/maxima/stackreporting.mac
new file mode 100644
index 0000000..14f9dd7
--- /dev/null
+++ b/stack/2020070100/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/2020070100/maxima/stackstrings.mac b/stack/2020070100/maxima/stackstrings.mac
new file mode 100644
index 0000000..6d85976
--- /dev/null
+++ b/stack/2020070100/maxima/stackstrings.mac
@@ -0,0 +1,296 @@
+/* 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))
+)$
+
+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(i<slength(tmp)), simp) do (
+ c:charat(tmp, ev(i+1, simp)),
+ if is(mode="raw") then (
+ if is(c="[") then tokens:append(tokens,[_stackjson_tokens_list_open])
+ elseif is(c="]") then tokens:append(tokens,[_stackjson_tokens_list_close])
+ elseif is(c="{") then tokens:append(tokens,[_stackjson_tokens_dict_open])
+ elseif is(c="}") then tokens:append(tokens,[_stackjson_tokens_dict_close])
+ elseif is(c=":") then tokens:append(tokens,[_stackjson_tokens_key_sep])
+ elseif is(c=",") then tokens:append(tokens,[_stackjson_tokens_list_sep])
+ elseif is(c="\"") then (mode:"string",lastslash:false,r:"")
+ elseif is(c="n") and is(charat(tmp,i+2)="u") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="l") then (i:i+3, tokens:append(tokens,[und]))
+ elseif is(c="t") and is(charat(tmp,i+2)="r") and is(charat(tmp,i+3)="u") and is(charat(tmp,i+4)="e") then (i:i+3, tokens:append(tokens,[true]))
+ elseif is(c="f") and is(charat(tmp,i+2)="a") and is(charat(tmp,i+3)="l") and is(charat(tmp,i+4)="s") and is(charat(tmp,i+5)="e") then (i:i+4, tokens:append(tokens,[false]))
+ elseif not is(sposition(c,sconcat(ascii(32),ascii(9),ascii(10),ascii(11),ascii(12),ascii(13)))=false) then (i:i)
+ elseif is(c="-") then (mode:"number",r:["-"])
+ elseif digitcharp(c) then (mode:"number",r:[c])
+ ) elseif is(mode="string") then (
+ if(lastslash) then (
+ lastslash:false,
+ if is(c="\\") then r:sconcat(r,"\\")
+ elseif is(c="n") then r:sconcat(r,ascii(10))
+ elseif is(c="t") then r:sconcat(r,ascii(9))
+ elseif is(c="r") then r:sconcat(r,ascii(13))
+ elseif is(c="b") then r:sconcat(r,ascii(8))
+ elseif is(c="f") then r:sconcat(r,ascii(12))
+ elseif is(c="\"") then r:sconcat(r,"\"")
+ elseif is(c="u") then (r:sconcat(r,unicode(stack_string_hex_to_num(substring(tmp,i+2,i+6)))),i:i+4)
+ else r:sconcat(r,c)
+ ) else (
+ if is(c="\\") then lastslash:true
+ elseif is(c="\"") then (tokens:append(tokens,[r]),mode:"raw")
+ else r:sconcat(r,c)
+ )
+ ) elseif is(mode="number") then (
+ if digitcharp(c) then r:append(r,[c])
+ elseif is(c=".") then r:append(r,[c])
+ elseif is(c="e") then r:append(r,[c])
+ elseif is(c="E") then r:append(r,[c])
+ elseif is(c="+") then r:append(r,[c])
+ elseif is(c="-") then r:append(r,[c])
+ else (tokens:append(tokens,[stack_string_parse_number(simplode(r))]),i:i-1,mode:"raw")
+ ),
+ i:i+1
+ ),
+
+ /* In the unlikely case that we have an atomic value e.g. string or number exit early. */
+ if is(length(tokens)=1) then return(tokens[1]),
+ dm:0,
+ /* Otherwise reduce grouppings. */
+ starts:sublist_indices(tokens, lambda([x], is(x=_stackjson_tokens_list_open) or is(x=_stackjson_tokens_dict_open))),
+ while ev(is(length(starts)>0), simp) do (
+ r:[],
+ nt:[],
+ i:1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<last(starts)), simp) do (nt:append(nt,[tokens[i]]), i:ev(i+1, simp)),
+ if is(tokens[last(starts)]=_stackjson_tokens_list_open) then (
+ i:last(starts)+1,
+ while not is(tokens[i]=_stackjson_tokens_list_close) do (
+ if not is(tokens[i]=_stackjson_tokens_list_sep) then r:append(r,[tokens[i]]),
+ i:ev(i+1, simp)
+ )
+ ) else (
+ r:["stack_map"],
+ i:ev(last(starts)+1, simp),
+ while not ev(is(tokens[i]=_stackjson_tokens_dict_close), simp) do (
+ if not ev(is(tokens[i]=_stackjson_tokens_list_sep), simp) then (
+ k:tokens[i],
+ v:tokens[ev(i+2, simp)],
+ r:append(r,[[k,v]]),
+ i:ev(i+3, simp)
+ ) else i:ev(i+1, simp)
+ )
+ ),
+ nt:append(nt,[r]),
+ i:i+1,
+ /* Change this to actual sublist as this is not the way to do it... */
+ while ev(is(i<length(tokens)+1), simp) do (nt:append(nt,[tokens[i]]),i:ev(i+1, simp)),
+ if ev(is(length(nt)<length(tokens)), simp) then dm:0,
+ tokens:nt,
+ /* If the string is bad we may loop forever for this we have an automated exit. */
+ dm:ev(dm+1, simp),
+ if ev(is(dm>20), 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)
+)$
+
+
+/* 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"
+ else if stringp(obj) then (
+ tmp:ssubst("\\\\","\\",obj),
+ tmp:ssubst("\\\"","\"",tmp),
+ tmp:ssubst("\\b",ascii(8),tmp),
+ tmp:ssubst("\\t",ascii(9),tmp),
+ tmp:ssubst("\\n",ascii(10),tmp),
+ tmp:ssubst("\\f",ascii(12),tmp),
+ tmp:ssubst("\\r",ascii(13),tmp),
+ r:sconcat("\"",tmp,"\"")
+ ) 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(obj) then r:string(obj)
+ else if numberp(obj) then r:string(float(obj))
+ else r:stackjson_stringify(string(obj)),
+ return(r)
+)$
+
+
+/**
+ * Special tools for dealing with CASText2, absolutely no use
+ * if you are not running a system with CASText2.
+ *
+ * Even if you have CASText2 enabled system these tools are very
+ * advanced and probably not for a novice author. Essenttially,
+ * 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.
+ */
+ if is(ct2[1]="jsxgraph") 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]))
+)$
diff --git a/stack/2020070100/maxima/stacktex.lisp b/stack/2020070100/maxima/stacktex.lisp
new file mode 100644
index 0000000..45c9728
--- /dev/null
+++ b/stack/2020070100/maxima/stacktex.lisp
@@ -0,0 +1,451 @@
+;; 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.
+;; If changes are made here, then we also need to update arccos.lisp
+
+(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 "\\mbox{ }"))
+ ((eql (elt x 0) #\\) x)
+ (t (concatenate 'string "\\mbox{" x "}"))))
+
+;; 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 %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)))
+
+;; insert left-angle-brackets for mncexpt. a^<n> 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
+ (not (member f '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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, 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 27 June 2020.
+;; Localise some Maxmia-generated strings
+
+(defprop $true "\\mathbf{!BOOLTRUE!}" texword)
+(defprop $false "\\mathbf{!BOOLFALSE!}" texword)
diff --git a/stack/2020070100/maxima/stacktex40.lisp b/stack/2020070100/maxima/stacktex40.lisp
new file mode 100644
index 0000000..9a7c45e
--- /dev/null
+++ b/stack/2020070100/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^<n> 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 '(%sum %product %derivative %integrate %at $texsub
+ %lsum %limit $pderivop $#pm#) :test #'eq)) ;; what else? what a hack...
+ (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)))
+ (t (tex (cadr x) l nil 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/2020070100/maxima/stackunits.mac b/stack/2020070100/maxima/stackunits.mac
new file mode 100644
index 0000000..5325729
--- /dev/null
+++ b/stack/2020070100/maxima/stackunits.mac
@@ -0,0 +1,602 @@
+/* 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 <http://www.gnu.org/licenses/>.
+*/
+
+
+/****************************************************************/
+/* Simplified tools for handling SI-units (+liters) */
+/* */
+/* Matti Harjula <matti.harjula@aalto.fi> */
+/* */
+/* Answer test added by */
+/* Chris Sangwin <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* V0.5 August 2016 */
+/****************************************************************/
+
+/* This code is commented out as these lists are now defined in the main code and
+ 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),
+ 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<bestc) then (best:va,bestc:vb)
+ )
+ ),
+ return(best)
+ ) else (
+ va:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*value))),
+ vb:stack_unit_si_to_si_base(stack_units_units(stackunits_make(10*target))),
+ ii:is(stack_units_units(va)!=stack_units_units(vb)),
+ va:stack_units_nums(va),
+ if is(va = NULLNUM) then
+ va:1,
+ vb:stack_units_nums(vb),
+ if is(vb = NULLNUM) then
+ vb:1,
+ conversionfactor:va/vb,
+ va:stack_units_nums(stackunits_make(value)),
+ if is(va = NULLNUM) then
+ va:1,
+ va:va*conversionfactor,
+ vb:stack_units_units(stackunits_make(target)),
+ if ii
+ then error("Units presentation requires compatible units.")
+ else return(stackunits(va,vb))
+ )
+)$
+
+/* Splits off the units from the end of a product. */
+stackunits_make(ex) := block([oldsimp, exn, exu, exl],
+ if (debug) then (print("stackunits_make: "), print(ex)),
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+ oldsimp:simp,
+ simp:false,
+ /* If we have only a number then return it, with a placeholder for units. */
+ if simp_numberp(float(ex)) then return(stackunits(ex, NULLUNITS)),
+ /* Atoms should be returned as just units. */
+ if atom(ex) then
+ return(stackunits(NULLNUM, ex)),
+ if safe_op(ex)="stackunits" then
+ return(ex),
+ if is_simp(op(ex)=STACKpmOPT) then return(block([numa,numb],
+ if length(args(ex))=1 then
+ (
+ numa:NULLNUM,
+ numb:first(args(ex))
+ )
+ else
+ (
+ numa:first(args(ex)),
+ numb:second(args(ex))
+ ),
+ if (debug) then print("stackunits_make: found +-. Preliminary split as ", print(numa), print(numb)),
+ numb:stackunits_make(numb),
+ if (debug) then print("stackunits_make: +- results give ", print(numa), print(numb)),
+ verb_arith(stackunits(numa, second(args(numb)),first(args(numb))))
+ )
+ ),
+ /* We have a special case x*1/s which we need to filter out at this stage. */
+ if safe_op(ex)="/" then
+ ex:stackunits_make_recip(ex),
+ exn:flatten_recurse_nouns(noun_arith(ex)),
+ if (debug) then (print("stackunits_make: nounarith expression is"), print(exn)),
+ /* If the student has indicated +- we deal with this. */
+ /* If we don't have units we are return what we are given. */
+ if is_simp(listofunits(ex)=[]) then
+ return(stackunits(ex, NULLUNITS)),
+ /* Edge case like s^(-1). */
+ if is_simp(op(exn)="noun^") then
+ exn:[exn] elseif not(is_simp(op(exn)="noun*")) then
+ return(stackunits(ex, NULLUNITS)),
+ exu:sublist(args(exn), lambda([ex2], not(stackunits_make_p(ex2)))),
+ exn:sublist(args(exn), lambda([ex2], stackunits_make_p(ex2))),
+ simp:oldsimp,
+ if (debug) then (print("stackunits_make: expressions split as"), print(exn), print(exu)),
+ /* Flag up if we genuinely have no numbers. */
+ if is_simp(emptyp(exn)) then
+ exn:[NULLNUM],
+ /* Flag up if we genuinely have no units. */
+ if is_simp(emptyp(exu)) then
+ exu:[NULLUNITS],
+ /* Transform (a^2)^-1 to a^(-2), for the units. */
+ exu:maplist(unary_minus_remove, exu),
+ exu:maplist(flatten_pow_minus_one, exu),
+ if (debug) then (print("stackunits_make: (1) reformulated units as "), print(exu)),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ exn:maplist(unary_minus_remove, exn),
+ exn:stack_units_rational_number(exn),
+ if (debug) then (print("stackunits_make: (2) reformulated numbers as "), print(exn)),
+ if is(first(exn) = UNARY_MINUS) then
+ (
+ exn:rest(exn),
+ exn[1]:ev(-1*exn[1],simp)
+ ),
+ if length(exn)=1 then exn:first(exn) else exn:apply("noun*", exn),
+ if length(exu)=1 then exu:first(exu) else exu:apply("noun*", exu),
+ if (debug) then (print("stackunits_make: (3) reformulated units as "), print(exu)),
+ verb_arith(stackunits(exn, exu))
+)$
+
+/* This function is deprecated. NO NOT USE. */
+stack_units_split(ex) := args(stackunits_make(ex))$
+
+/* Turn stackunits into a product in a safe way. */
+stackunits_to_product(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ return(ex),
+ if stack_units_units(ex) = NULLUNITS then
+ return(stack_units_nums(ex)),
+ if stack_units_nums(ex) = NULLNUM then
+ return(stack_units_units(ex)),
+ apply("*", args(ex))
+)$
+
+/* Predicate function used as a filter in stackunits_make. */
+stackunits_make_p(ex) := block(
+ if simp_numberp(ex) or is_simp(ex=UNARY_MINUS) or is_simp(ex=QMCHAR) then
+ return(true),
+ if emptyp(listofvars(ex)) then
+ return(true),
+ if simp_numberp(ev(float(verb_arith(ex)), simp)) then
+ return(true),
+ return(false)
+)$
+
+/* Does something look like a rational number? */
+stack_units_rational_number(ex) := block(
+ if length(ex)=1 and safe_op(first(ex))="noun^" and is(second(args(first(ex)))=-1) then return([1/first(args(first(ex)))]),
+ if not(length(ex)=2) then
+ return(ex),
+ if not(integerp(first(ex))) or atom(second(ex)) then return(ex),
+ if safe_op(second(ex))="noun^" and is(second(args(second(ex)))=-1) then return([first(ex)/first(args(second(ex)))]),
+ ex
+)$
+
+/* We have a special case x*1/s which we need to filter out at this stage. */
+stackunits_make_recip(ex) := block([ex1,ex2],
+ if not(safe_op(ex)="/") then
+ return(ex),
+ ex1:first(args(ex)),
+ ex2:second(args(ex)),
+ if not(safe_op(ex1)="*") then
+ return(ex),
+ ex1:reverse(args(ex1)),
+ if not(is_simp((first(ex1)=1)))
+ then return(ex),
+ if is(length(ex1)=2) then
+ return(second(ex1)/ex2),
+ reverse(rest(ex1))/ex2
+)$
+
+/* Add utility functions to get units and numerical parts. */
+stack_units_units(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(second(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(second(args(su))),
+ return(ex)
+)$
+
+stack_units_nums(ex) := block([su],
+ if safe_op(ex) = "stackunits" then
+ return(first(args(ex))),
+ su:stackunits_make(ex),
+ if safe_op(su) = "stackunits" then
+ return(first(args(su))),
+ return(ex)
+)$
+
+stack_units_err(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if not(is(safe_op(ex) = "stackunits")) then
+ return(0),
+ if is_simp(length(args(ex))=3) then
+ return(third(args(ex))),
+ return(0)
+)$
+
+stack_units_errp(ex) := block(
+ if not(safe_op(ex) = "stackunits") then
+ ex:stackunits_make(ex),
+ if length(args(ex))=3 then
+ return(true),
+ return(false)
+)$
+
+/* Validate an expression which is expected to have units. */
+stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:false, exs, SAU, SBU],
+ /* Check the display option. */
+ if not(fracdisp = "inline" or fracdisp = "negpow") then block(
+ error("stack_validate_units: fracdisp argument must be either inline or negpow only.")
+ ),
+ /* Try to simply the expression to catch CAS errors. */
+ exs:errcatch(ev(expr, simp)),
+ if is_simp(exs = []) then return(false),
+ if length(expr)#1 then
+ print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr:first(expr),
+ /* Declare all symobols as "units", and change their TeX display. */
+ stack_unit_si_declare(false),
+
+ /* An empty answer is validated as valid! */
+ if (expr = EMPTYANSWER) then return(expr),
+
+ /* Do not check for floats. They are always ok here. */
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and not(all_lowest_termsex(expr)) then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* SA should be only an expression. */
+ if not(expressionp(expr) or is(safe_op(expr)=STACKpmOPT)) then
+ (print(StackAddFeedback("", "ATUnits_SA_not_expression")), return(expr)),
+
+ /* Check if the student has correctly used units.*/
+ SAU:stackunits_make(expr),
+ SBU:stackunits_make(TAns),
+ if (debug) then (print("stack_validate_units working with: "), print(SAU), print(SBU)),
+
+ /* Deal with the display of floats. */
+ /* Only use the number template when we have exactly 1 float in the expression. */
+ stackfltfmt:"~a",
+ if numberp(stack_units_nums(SAU)) or is(safe_op(stack_units_nums(SAU)) = "-") then
+ stackfltfmt:fltfmt
+ else if is(safe_op(stack_units_nums(SAU)) = "*") then
+ if is(length(sublist(args(stack_units_nums(SAU)), numberp)) <= 1) then
+ stackfltfmt:fltfmt,
+
+ /* Check if stackunits_make appears to have done something sensible. */
+ /* Student types only units. This should always be invalid. */
+ if is_simp(stack_units_nums(SAU) = NULLNUM) then
+ print(StackAddFeedback("", "ATUnits_SA_only_units"))
+ else if not(emptyp(listofvars(stack_units_nums((SAU))))) then
+ print(StackAddFeedback("", "ATUnits_SA_bad_units"))
+ else block(
+ /* Student should use units if and only if the teacher uses units. */
+ if is_simp(stack_units_units(SAU) = NULLUNITS) and not(is_simp(stack_units_units(SBU) = NULLUNITS)) then
+ print(StackAddFeedback("", "ATUnits_SA_no_units")),
+ if not(is_simp(stack_units_units(SAU) = NULLUNITS)) and is_simp(stack_units_units(SBU) = NULLUNITS) then
+ print(StackAddFeedback("", "ATUnits_SA_excess_units"))
+ ),
+
+ /* Check if the student has added in error bounds. */
+ if stack_units_errp(SAU) then
+ print(StackAddFeedback("", "ATUnits_SA_errorbounds_invalid")),
+
+ /* Add in an option to control the display of the units. */
+ expr:SAU,
+ if (debug) then (print("stack_validate_units has: "), print(expr)),
+ if fracdisp = "inline" then
+ (
+ stack_disp_fractions("i"),
+ if stack_units_errp(SAU) then
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp), ev(stack_units_err(SAU),simp))
+ else
+ expr:stackunits(stack_units_nums(SAU), ev(stack_units_units(SAU),simp))
+ ),
+ if (debug) then (print(expr)),
+ expr:detexcolor(expr),
+ return(expr)
+)$
+
+/* Finer control over display of units, separating out the number from the units. */
+stackunitstex(ex) := block ([a, b, c, astr],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ astr:tex1(a),
+ if not(atom(a)) and safe_op(a)="+" and not(is(b=NULLUNITS)) then
+ astr:sconcat("\\left( ", astr, "\\right)"),
+ if length(args(ex))=3 then
+ astr:sconcat(astr, "\\pm ", third(args(ex))),
+ /* Fine tune the edge cases. */
+ if is(safe_op(b)="/") then
+ if (is(first(args(b))=1)) then return(sconcat(astr,"\\times ",tex1(b))),
+ /* Otherwise.... */
+ sconcat(astr,"\\, ",tex1(b))
+)$
+texput(stackunits, stackunitstex);
+texput(NULLUNITS, "");
+texput(NULLNUM, "");
+
+/* Units answer tests. */
+ATUnits(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "SigFigs")$
+ATUnitsStrict(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsStrictSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "SigFigs")$
+ATUnitsRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Relative")$
+ATUnitsStrictRelative(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Relative")$
+ATUnitsAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "Absolute")$
+ATUnitsStrictAbsolute(SA, SB, SO) := ATUnitsFun(SA, SB, SO, true, "Absolute")$
+
+/* This function has two options:
+ boolean: strictp determines if the test should be "strict" in requiging exactly the correct units.
+ numtest: string Chooses the numerical test applied to the numerical part.
+*/
+ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
+ SAU, SBU, SOU, SAU1, SBU1, SOU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ if (is(_EC(errcatch(SAA:ev(SA, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ if (is(_EC(errcatch(SBB:ev(SB, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ if (is(_EC(errcatch(SOO:ev(SO, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_Opt"), ""]),
+
+ ol:SO,
+
+ /* SA should be only an expression. */
+ if not(expressionp(SA)) then
+ return([false, false, StackAddNote("", "ATUnits_SA_not_expression"), StackAddFeedback("", "ATUnits_SA_not_expression")]),
+
+ /* SB should be only an expression. */
+ if not(expressionp(SB)) then
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATUnits_TA_not_expression"), StackAddFeedback("", "TEST_FAILED_Q")])),
+
+ /* SA must have some units. */
+ if simp_numberp(SA) then
+ return([false, false, StackAddNote("", "ATUnits_SA_no_units"), StackAddFeedback("", "ATUnits_SA_no_units")]),
+
+ /* Load and setup units. */
+ if not(member(units, features)) then
+ stack_unit_si_declare(true),
+
+ if (debug) then (print("ATUnitsFun: raw input: "), print(SA), print(SB)),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(SB),
+ /* If the teacher has not supplied numerical information then it is assumed to be 1.0.
+ The teacher's answer could well be the result of a calculation in which 1.0*units -> 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)
+ 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)
+ 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/2020070100/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2020070100/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000..d4e798f
--- /dev/null
+++ b/stack/2020070100/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"<mspace/><fnm> %and </fnm><mspace/>" wxxmlsym)
+(defprop %and "<fnm> %and </fnm>" 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 "<mspace/><fnm> %or </fnm><mspace/>" wxxmlsym)
+(defprop %or "<fnm> %or </fnm>" 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/2020070100/maxima/unittests_load.mac b/stack/2020070100/maxima/unittests_load.mac
new file mode 100644
index 0000000..072158a
--- /dev/null
+++ b/stack/2020070100/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)$
+
+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/2020070100/maxima/utils.mac b/stack/2020070100/maxima/utils.mac
new file mode 100644
index 0000000..ea52d53
--- /dev/null
+++ b/stack/2020070100/maxima/utils.mac
@@ -0,0 +1,229 @@
+/* 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(string_to_escape) := block([tmp],
+ tmp: ssubst("&", "&", string_to_escape),
+ tmp: ssubst("'", "'", tmp), /* ' is for XHTML, we need to still deal with HTML. */
+ tmp: ssubst(""", "\"", tmp),
+ tmp: ssubst(">", ">", tmp),
+ tmp: ssubst("<", "<", tmp),
+ return(tmp)
+)$
+
+/* Same for generating ECMAScript strings. */
+str_to_js(string_to_escape) := block([tmp,lines],
+ tmp: ssubst("\\\\", "\\", string_to_escape),
+ tmp: ssubst("\\\"", "\"", tmp),
+ tmp: ssubst("\\'", "'", tmp),
+ tmp: ssubst("\\b", ascii(8), tmp),
+ tmp: ssubst("\\t", ascii(9), tmp),
+ tmp: ssubst("\\n", ascii(10), tmp),
+ tmp: ssubst("\\v", ascii(11), tmp),
+ tmp: ssubst("\\r", ascii(13), tmp), /* \b\t\v\r might as well set to "" but maybe someone uses them to do magic. */
+ return(tmp)
+)$
+
+/* 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 (
+ 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 (
+ 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", "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",
+ "errcatch", "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", "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"
+}$
+
+/* 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)
+)$
diff --git a/versions b/versions
index 71b947c..b12e282 100644
--- a/versions
+++ b/versions
@@ -5,3 +5,6 @@
5.41.0 2.0.2 2018080600
5.41.0 2.0.2 2019090200
5.41.0 2.0.2 2020042000
+5.41.0 2.0.2 2020052700
+5.41.0 2.0.2 2020061000
+5.41.0 2.0.2 2020070100
--
GitLab