diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..19fa63264c56a2e0e98aa45e12ab2f0ec50f5f42
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,19 @@
+# Swap
+[._]*.s[a-v][a-z]
+!*.svg # comment out if you don't need vector files
+[._]*.sw[a-p]
+[._]s[a-rt-v][a-z]
+[._]ss[a-gi-z]
+[._]sw[a-p]
+
+# Session
+Session.vim
+Sessionx.vim
+
+# Temporary
+.netrwhist
+*~
+# Auto-generated tag files
+tags
+# Persistent undo
+[._]*.un~
diff --git a/.gitmodules b/.gitmodules
deleted file mode 100644
index 6a05ea8a9652bf9679be6bad8649f8e75ced929d..0000000000000000000000000000000000000000
--- a/.gitmodules
+++ /dev/null
@@ -1,11 +0,0 @@
-[submodule "assStackQuestion"]
- path = assStackQuestion
- url = https://github.com/ilifau/assStackQuestion.git
- branch = master-ilias53
-[submodule "goe_web"]
- path = goe_web
- url = https://gitlab.gwdg.de/martin.heide/goe_web.git
- branch = master
-[submodule "moodle-qtype_stack"]
- path = moodle-qtype_stack
- url = https://github.com/maths/moodle-qtype_stack.git
diff --git a/Dockerfile b/Dockerfile
index 9753ac0673517dd157bb3bc148a9f411eaffbacb..8615be52fb07336082dd21282b2c00fd65bfac6c 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -2,7 +2,7 @@ FROM debian:stable
# e.g. 5.41.0
ARG MAXIMA_VERSION
-# e.g. 1.4.11
+# e.g. 2.0.22.0.2
ARG SBCL_VERSION
# e.g. assStackQuestion/classes/stack/maxima
ARG LIB_PATH
diff --git a/assStackQuestion b/assStackQuestion
deleted file mode 160000
index 12439ff1a3a16280e115ce1fab4a23b985c90509..0000000000000000000000000000000000000000
--- a/assStackQuestion
+++ /dev/null
@@ -1 +0,0 @@
-Subproject commit 12439ff1a3a16280e115ce1fab4a23b985c90509
diff --git a/bin/web b/bin/web
deleted file mode 100755
index 2d6a955cf2103a1cddec441998c1ee1cb8a08f77..0000000000000000000000000000000000000000
Binary files a/bin/web and /dev/null differ
diff --git a/build.sh b/build.sh
index 27b759658c6e81899a68929451b6e690fd9ccd0e..b20d1c5eed4d796df7f7205c7f5b259925239f13 100755
--- a/build.sh
+++ b/build.sh
@@ -1,26 +1,8 @@
-#/bin/bash
REGISTRY=$1
-
-for sbcl_version in $(cat sbcl_version); do
-for maxima_version in $(cat maxima_version); do
-for stack_version in $(cat stack_version); do
-IFS=",";
-set ${stack_version};
-# checkout repository
-cd assStackQuestion;
-#git checkout $2
-cd ../
-./buildimage.sh ${sbcl_version} ${maxima_version} $1 "assStackQuestion/classes/stack/maxima" ${REGISTRY} || exit 1
-unset IFS
-done
-#for moodle_version in $(cat moodle_version); do
-#cd moodle-qtype_stack
-#git checkout ${moodle_version}
-#cd ../
-#echo "starting to build image for:"
-#echo "sbcl: "${sbcl_version}
-#echo "maxima: "${maxima_version}
-#echo "moodle: "${moodle_version}
-#done
-done
+grep -v '^#' versions | \
+while read -r line; do
+ maxima_version="$(echo "$line" | cut -f1)"
+ sbcl_version="$(echo "$line" | cut -f2)"
+ stack_version="$(echo "$line" | cut -f3)"
+ ./buildimage.sh "${sbcl_version}" "${maxima_version}" "$stack_version" "stack/$stack_version/maxima" "${REGISTRY}" || exit 1
done
diff --git a/buildimage.sh b/buildimage.sh
index 073d99aa73983c72e06e950c182978cc792c7d80..25309a7547522b2715b88a7bf9d6f79b4733e06b 100755
--- a/buildimage.sh
+++ b/buildimage.sh
@@ -1,4 +1,4 @@
-#/bin/bash
+##/bin/bash
# arg1: sbcl version
# arg2: maxima version
# arg3: stack or moodle version: "stack-XXX" or "moodlev.X"
@@ -6,17 +6,17 @@
# arg5: REGISTRY IP
#
echo "starting to build image for:"
-echo "sbcl: "$1
-echo "maxima: "$2
-echo $3
+echo "sbcl: $1"
+echo "maxima: $2"
+echo "stack: $3"
# tag the image
-IMAGENAME=$5"/sbcl"$1"_maxima"$2"_"$3
+IMAGENAME="$5/sbcl-$1_maxima-$2_stack-$3"
# check if the image already exists on the server
-docker pull ${IMAGENAME}
+docker pull "${IMAGENAME}"
# build it
-docker build -t ${IMAGENAME} --build-arg MAXIMA_VERSION=$2 --build-arg SBCL_VERSION=$1 --build-arg LIB_PATH=$4 . || exit 1
-echo ${IMAGENAME}" wurde erfolgreich gebaut."
+docker build -t "${IMAGENAME}" --build-arg MAXIMA_VERSION="$2" --build-arg SBCL_VERSION="$1" --build-arg LIB_PATH="$4" . || exit 1
+echo "${IMAGENAME} wurde erfolgreich gebaut."
# testing?
# push it
-docker push ${IMAGENAME}
+docker push "${IMAGENAME}"
diff --git a/goe_web b/goe_web
deleted file mode 160000
index 249bdf42d888a5c4a6254f79a5c95b877e087d81..0000000000000000000000000000000000000000
--- a/goe_web
+++ /dev/null
@@ -1 +0,0 @@
-Subproject commit 249bdf42d888a5c4a6254f79a5c95b877e087d81
diff --git a/maxima_version b/maxima_version
deleted file mode 100644
index b9f26f97db57c2ddbefbdd65e79b31b18cf9091e..0000000000000000000000000000000000000000
--- a/maxima_version
+++ /dev/null
@@ -1 +0,0 @@
-5.41.0
diff --git a/moodle-qtype_stack b/moodle-qtype_stack
deleted file mode 160000
index 1cb32dc19faeb428b3b8daca0f72e2478877ed6c..0000000000000000000000000000000000000000
--- a/moodle-qtype_stack
+++ /dev/null
@@ -1 +0,0 @@
-Subproject commit 1cb32dc19faeb428b3b8daca0f72e2478877ed6c
diff --git a/moodle_version b/moodle_version
deleted file mode 100644
index 23fef47a71db2c1106baaf2d29bbd573e0d57ac1..0000000000000000000000000000000000000000
--- a/moodle_version
+++ /dev/null
@@ -1,27 +0,0 @@
-v4.3.0beta3
-v4.3.0beta2
-v4.3.0beta
-v4.3.0alpha
-v4.2.3
-v4.2.2
-v4.2.2a
-v4.2.1
-v4.2
-v4.1
-v4.0.1
-v4.0
-v3.6
-v3.5.7
-v3.5.6
-v3.5.5
-v3.5
-v3.4
-v3.3.3
-v3.3.2
-v3.3.1
-v3.3
-v3.2
-v3.1
-v3.0
-v3.0rc1
-v3.0beta1
diff --git a/sbcl_version b/sbcl_version
deleted file mode 100644
index e9307ca5751b252b31c533d41f61df140d3f7537..0000000000000000000000000000000000000000
--- a/sbcl_version
+++ /dev/null
@@ -1 +0,0 @@
-2.0.2
diff --git a/stack/2014083000/maxima/arccos.lisp b/stack/2014083000/maxima/arccos.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..963ff6b45f83923546f7163cc973266c91102e7e
--- /dev/null
+++ b/stack/2014083000/maxima/arccos.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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/2014083000/maxima/assessment.mac b/stack/2014083000/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..24ebb7e161c02040c133e9462d1681ff31103f73
--- /dev/null
+++ b/stack/2014083000/maxima/assessment.mac
@@ -0,0 +1,757 @@
+/* Author Chris Sangwin
+ Loughborough University
+ Copyright (C) 2014 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, <chris@sangwin.com> */
+/* V0.6 September 2014 */
+/* */
+/****************************************************************/
+
+MAXIMA_VERSION:map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp))$
+MAXIMA_VERSION_NUM:float(MAXIMA_VERSION[2]+MAXIMA_VERSION[3]/10)$
+
+/* Note how Maxima has changes this.... */
+DIV_OP:"//"$
+if MAXIMA_VERSION_NUM>=15.0 then DIV_OP:"/"$
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+if not(?functionp('poly_reduced_grobner)) then load("grobner");
+
+/* ********************************** */
+/* Parts of expressions */
+/* ********************************** */
+
+/* op(ex) is unsafe on atoms: this is a fix. */
+/* This function always returns a string */
+safe_op(ex) := block(
+ if mapatom(ex) then return(""),
+ if stringp(op(ex)) then return(op(ex)) else return(string(op(ex)))
+)$
+
+/* This function takes an expression ex and returns a list of coefficients of v */
+coeff_list(ex,v):= block([deg,kloop,cl],
+ cl:[],
+ ex:ev(expand(ex),simp),
+ deg:hipow(ex,v),
+ ev(for kloop:0 thru deg do
+ cl:append(cl,[coeff(ex,v,kloop)]),simp),
+ cl
+)$
+
+/* This function takes an expression ex and returns a list of nonzero coefficients of v */
+coeff_list_nz(ex,v):= block([deg,kloop,cl],
+ cl:[],
+ ex:ev(expand(ex),simp),
+ deg:hipow(ex,v),
+ ev(for kloop:0 thru deg do
+ if coeff(ex,v,kloop)#0 then cl:append(cl,[[kloop,coeff(ex,v,kloop)]]),simp),
+ cl
+)$
+
+/* 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)))$
+
+/* ********************************** */
+/* 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"$
+
+/* 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. */
+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)))$
+
+
+/* ********************************** */
+/* 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)
+)$
+
+expressionp(ex) := block(
+ if matrixp(ex) or listp(ex) or equationp(ex) or inequalityp(ex) or setp(ex) or functionp(ex) then
+ return (false),
+ return(true)
+);
+
+/* Checks that an expression is a polynomial */
+polynomialpsimp(e):= polynomialp(e, listofvars(e))$
+
+/* ********************************** */
+/* 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
+)$
+
+/* 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),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)
+)$
+
+/* Write the number x in n decimal places */
+decimalplaces(x,n) := ev(float(round(10^n*float(x))/(10^n)),simp)$
+
+/* Write numbers in significant figures */
+/* Matti Pauna, Sun, 23 Oct 2011 */
+significantfigures(x,n) := block([fpprec:128,fpprintprec,simp:true,ex,ex2],
+ if x = 0 then return(0),
+ if x = 0.0 then return(0.0),
+ sign_of_x : signum(x),
+ x : abs(x),
+ ex:floor(float(log(x)/log(10))),
+ ex2:round(float(x/10^(ex-n+1))),
+ ex2:float(ex2*10^(ex-n+1)),
+ if floor(ex2)=ratsimp(ex2) then ex2:ratsimp(ex2),
+ return(sign_of_x*ex2)
+);
+
+
+scientific_notation(x) := block([simp:false,fpprintprec,ex,ex2,ex3],
+ if real_numberp(x) and ev(x>0,simp) then (
+ ex:ev(floor(float(log(x)/log(10))),simp),
+ ex2:ev(float(x/10^ex),simp),
+ ex3:ex2*10^ex,
+ return(ex3)
+ ) else return (x)
+);
+
+/* 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 op(ex)#"*" then
+ ret:[ex]
+ else
+ ret:args(ex),
+ /* now 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)#DIV_OP then return(true),
+ 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)=DIV_OP and simp_numberp(num(ex)) and simp_numberp(denom(ex)) then return([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)
+)$
+
+/* compare with*/
+/* coefl:map('first,rest(coeffs(SA,x))) */
+
+/* ********************************** */
+/* Inequalities */
+/* ********************************** */
+
+infix("=>");
+"=>"(a,b):=a>=b;
+infix("=<");
+"=<"(a,b):=a<=b;
+
+
+/* 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 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,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 an single variable polynomial expression into a +1/-1 monic polynomial */
+make_monic(ex):=block(
+ if mapatom(ex) then return(ex),
+ if not(polynomialpsimp(ex)) then return(ex),
+ if length(listofvars(ex))>1 then return(ex),
+ ex:expand(ex),
+ ev(expand(ex/abs(coeff(ex,first(listofvars(ex)),degree(ex,first(listofvars(ex)))))),simp)
+)$
+
+/* Writes an expression in a cannonical form */
+ineqorder(ex) := ineqorder_f(ev(ineqprepare(ex),simp))$
+
+/* This function prepares inequalities, removes duplicates (e.g. x>1 and 1<x end up the same. Finally it orders the result. */
+ineqorder_f(ex) := block(
+ if mapatom(ex) then return(ex),
+ if op(ex)="and" then return(apply("and",sort(listify(setify((map(ineqorder_f,args(ex)))))))),
+ if op(ex)="or" then return(apply("or",sort(listify(setify((map(ineqorder_f,args(ex)))))))),
+ if op(ex)="not" then return(apply("not",sort(listify(setify((map(ineqorder_f,args(ex)))))))),
+ return(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/9/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.
+*/
+algebraic_equivalence(SA, SB) :=
+ block([keepfloat, trigexpand, logexpand, ex, vi],
+ /* Reject obviously different expressions. These can be very time consuming in the tests below. */
+ /* The code below is actually making the situation worse: needs reconsidering. */
+ if numerical_not_alg_equiv(SA, SB) then return(false),
+ trigexpand:true,
+ 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))),
+ /* Try not to expand out: pure numbers */
+ ex:errcatch(ev(SA-SB,simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ ex:ex[1],
+ if numberp(ex) then
+ if rat(ex)=0 then return(true)
+ else return (false),
+ /* Try not to expand out: factoring */
+ ex:errcatch(ev(factor(SA-SB),simp)),
+ if ex=[] then (print("algebraic_equivalence: factoring the difference of two expressions threw an error."), return(false)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ if ratsimp(ex)=0 then return(true),
+ /* Next we expand out the difference. */
+ ex:errcatch(ev(fullratsimp(SA-SB), simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 */
+ ex:trigsimp(ex),
+ 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([lv, sz],
+ /* 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. */
+ lv:listify(union(setify(listofvars(p1)), setify(listofvars(p2)))),
+ /* Now we evaluate the difference of the expressions at each variable. */
+ lv:zip_with("=", lv, makelist(float((sqrt(2)^k+k*%pi)/4), k, length(lv))),
+ p1:errcatch(ev(float(p1), lv, numer_pbranch:true)),
+ if is(p1 = []) then (print("STACK: ignore previous error."), return(false)),
+ p2:errcatch(ev(float(p2), lv, numer_pbranch:true)),
+ if is(p2 = []) then (print("STACK: ignore previous error."), return(false)),
+ sz:errcatch(abs(float(first(p1)-first(p2)))),
+ /* 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:listofvars(ex1),
+ lv2:listofvars(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 []
+)$
+
+/* ********************************** */
+/* 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+", 100);
+prefix("noun-", 100);
+nary("noun*", 120);
+infix("noun/", 122, 123);
+infix("noun^", 140, 139);
+prefix("UNARY_RECIP", 100);
+
+/* (2) */
+load("noun_arith.lisp");
+
+/* (3) */
+
+declare("noun+", commutative);
+declare("noun+", lassociative);
+declare("noun+", rassociative);
+
+declare("noun*", commutative);
+declare("noun*", lassociative);
+declare("noun*", rassociative);
+
+/* (4) */
+verb_arith(ex) := block(
+ ex:subst("+", "noun+", ex),
+ ex:subst("*", "noun*", ex),
+ ex:subst("-", "noun-", ex),
+ ex:subst(DIV_OP, "noun/", ex),
+ ex:subst("^", "noun^", ex),
+ define(UNARY_RECIP a, a^(-1)),
+ ex:ev(ex, UNARY_MINUS=-1),
+ remfunction("noun+", "noun*", "noun/", "noun^", "noun-"),
+ ex
+)$
+
+/* (5) */
+noun_arith(ex) := block(
+ 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)), DIV_OP, ex),
+ ex:subst("noun^", "^", ex),
+ ev(ex)
+)$
+
+/* (6) 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:ev(ex, simp),
+ ex:subst("noun+", "+", ex),
+ ex:subst("noun*", "*", ex),
+ ex:subst("noun-", "-", ex),
+ ex
+)$
+
+/* (7) */
+/* Returns true iff ex1 and ex2 are equal up to commutativity and associativity */
+equals_commute_associate(ex1,ex2) := block([oldsimp,ex1n,ex2n,ret],
+ oldsimp:simp,
+ simp:false,
+ ex1n:noun_arith(ex1),
+ ex2n:noun_arith(ex2),
+ simp:true,
+ if ex1n=ex2n then ret:true else ret:false,
+ simp:oldsimp,
+ ret
+)$
+
+/* An answer test in the context of commutative+associative addition and multiplication.*/
+ATEqualComAss(sa,sb) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB],
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]),
+
+ /* We need 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], ATAlgEquivfun(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])
+)$
+
+
+/* ********************************** */
+/* 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 ev(argfac=factor(argfac), simp) then
+ return(true),
+ if mapatom(argfac) then
+ return(false),
+ /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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 (
+ print("comp_square: var should be an atom but not a number. "),
+ return(ex)
+ ),
+ ex:ratsimp(expand(ex)),
+ if not(polynomialp(ex, [var])) then (
+ print("comp_square: ex should be a polynomial in var. "),
+ return(ex)
+ ),
+ if hipow(ex, var)#2 then (
+ print("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))
+)$
+
+
+/*********************/
+/* Matrix operations */
+/*********************/
+
+/*
+ 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
+)$
+
+addrow(m,i,j,k) := block([n,p],
+ require_matrix(m, "first", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_integer(j, "third", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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 : addrow (p,k,ci,-p[k,cj]))),
+ ci : ci+1, cj : cj+1)),
+ p
+)$
+
+/* ********************************** */
+/* 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));
+
+
+/* ********************************** */
+/* Answer tests */
+/* ********************************** */
+
+AnswerTests : [AlgEquiv, EqualComAss, CasEqual, SameType, SubstEquiv, SysEquiv, Expanded, FacForm, SingleFrac, PartFrac, CompSquare, GT, GTE, NumAbsolute, NumRelative, NumSigFigs, LowestTerms, Diff, Int, String, StringSloppy, RegExp]$
+
diff --git a/stack/2014083000/maxima/assessment.texi b/stack/2014083000/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2014083000/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/2014083000/maxima/complexi.lisp b/stack/2014083000/maxima/complexi.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8be0972956d17463313be86ea1bd76f1b9552cbb
--- /dev/null
+++ b/stack/2014083000/maxima/complexi.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{i}" texword)
+
+(defprop $%i "<mi>i</mi> " mathmlword)
diff --git a/stack/2014083000/maxima/complexj.lisp b/stack/2014083000/maxima/complexj.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1fdfd5b91a8993b84fc72fd9f39114151c8dd4ce
--- /dev/null
+++ b/stack/2014083000/maxima/complexj.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{j}" texword)
+
+(defprop $%i "<mi>j</mi> " mathmlword)
diff --git a/stack/2014083000/maxima/cos-1.lisp b/stack/2014083000/maxima/cos-1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7cdb2e2d0c69d196c7ae93ea9c9f2740ece76b59
--- /dev/null
+++ b/stack/2014083000/maxima/cos-1.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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 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/2014083000/maxima/elementary.mac b/stack/2014083000/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..de8f9c8f61fc1a15ff32502a8fa83616b5b9889d
--- /dev/null
+++ b/stack/2014083000/maxima/elementary.mac
@@ -0,0 +1,477 @@
+/* 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"]$
+ALL_TRANS:append(ALG_TRANS,ID_TRANS,INT_ARITH,NEG_TRANS,DIV_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 print("ERROR: 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],
+ l1:sublist(l, lambda([ex],safe_op(ex)#"RECIP")),
+ l2:sublist(l, lambda([ex],safe_op(ex)="RECIP")),
+ append(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))]))
+)$
+
+/*******************************************/
+/* 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/2014083000/maxima/expandfeedback.mac b/stack/2014083000/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2014083000/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/2014083000/maxima/experimental.mac b/stack/2014083000/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..7f04855f3fe5c048c8060df898625c7f08aba699
--- /dev/null
+++ b/stack/2014083000/maxima/experimental.mac
@@ -0,0 +1,298 @@
+/* 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 */
+
+/* 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))));
+
+/****************************************************************/
+/* Inequality functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.2 July 2013 */
+/* */
+/****************************************************************/
+
+/* Determines if we have a linear inequality in one variable */
+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 is(degree(lhs(ex2),first(listofvars(ex2)))=1) then return(true),
+ return(false)
+)$
+
+
+/* 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)
+)$
+
+/* Reformat an 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)
+)$
+
+/* Does the expression define a *single* interval, by means of an inequality? */
+/* E.g. 1<x and x<7 */
+/* We only accept linear inequalities in one variable, combined by "and" */
+/* We don't expect this to be the *simplest* form, that is later. */
+/* A single inequality is a half open interval. */
+/* true is the whole real line, false is the empty set. */
+interval_inequalityp(ex):= block(
+ /* Emptyset and real line. */
+ if equal(ex, true) then return(true),
+ if equal(ex, false) then return(true),
+ if atom(ex) then return(false),
+ /* Half open intervals */
+ if linear_inequalityp(ex) then return(true),
+ if not(op(ex)="and") then return(false),
+ if is(length(listofvars(ex))>1) then return(false),
+ return(all_listp(linear_inequalityp, args(ex)))
+)$
+
+/* Takes a real interval and returns the canonical form for this inequality */
+/* a<x and x<b */
+/* or, true, false, or a single inequality */
+interval_simplify(ex):=block([ex2,v,a,b],
+ if not(interval_inequalityp(ex)) then return(ex),
+ /* We know we have an interval inequality. */
+ if equal(ex, true) then return(true),
+ if equal(ex, false) then return(false),
+ /* Remove redundant inequalities: might leave us with a single one. */
+ ex:ineq_rem_redundant(ex),
+ if linear_inequalityp(ex) then return(inequality_disp(ex)),
+ /* Now we are in business. We have a single interval, of two inequalities. */
+ ex:map(inequality_disp,ex),
+ v:listofvars(ex),
+ if equal(v,lhs(first(ex))) then ex:second(args(ex)) and first(args(ex)),
+ /* This should now be in the right form. */
+ /* Check for an empty set (2 possibilities) */
+ if (lhs(first(args(ex))))>(rhs(second(args(ex)))) then return(false),
+ if (lhs(first(args(ex))))=(rhs(second(args(ex)))) and not(safe_op(first(args(ex)))="<=" and safe_op(second(args(ex)))="<=") then return(false),
+ ex
+)$
+
+/* This removes redundant linear inequalities such as x>1 or x>0 -> x>0 */
+ineq_rem_redundant(ex) := block([exl,exn,exg,exl,exo,exv],
+ if atom(ex) then return(ex),
+ if not(op(ex)="and" or op(ex)="or") then return(ex),
+ /* Recurse over the expression */
+ ex:apply(op(ex),maplist(ineq_rem_redundant,args(ex))),
+ if 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 different variables */
+ 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),
+ apply(op(ex),append(exn,exl))
+ )$
+
+/* Take a list of linear inequalities the same single variable, and an 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 print("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)))),
+ m3:sort(listify(setify(maplist(second,m2)))), /* get list of operators. Used to sort out >, >= etc. */
+ 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 a single inequality in a single variable by factoring, where possible expressing the result as irreducible inequalities. */
+factor_ineq_solve(ex):=block([ex2,ex3,exop,m,fl,p],
+ if not(inequalityp(ex)) then return(ex),
+ if length(listofvars(ex))#1 then return(ex),
+ ex2:ineqprepare(ex),
+ exop:op(ex2), /* This is for >, >= */
+ ex2:factor(lhs(ex2)),
+ if atom(ex2) then return(ex),
+ /* Create a list of factors */
+ if is(op(ex2)="-") then m:true else m:false,
+ if m then fl:first(args(ex2)) else fl:ex2,
+ if safe_op(fl)="*" then fl:args(fl) else fl:[fl],
+ /* 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:maplist(interval_simplify,ex3),
+ ex3:reverse(sort(ex3)),
+ ex3:apply("or",ex3)
+)$
+
+/* Negates the 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)
+)$
+
+/* This function takes a list of inequalities, ex and a list of index numbers l, and 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[l[k]]:neg_ineq(ex[l[k]]),
+ ex
+)$
+
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* 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 (print("STACK exception: node_no expects its first argument to be a list."), return(false)),
+ if not(integerp(num)) then (print("STACK exception: node_no expects its second argument to be an integer."), return(false)),
+ if is(length(prt)<num) then (print("STACK exception: node_no expects its second argument to less than the length of the first."), return(false)),
+ /* 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 (print("STACK exception: traverse_prt expects its argument to be a list."), return(false)),
+ if not(alllistp(equationp,inputs)) then (print("STACK exception: traverse_prt expects its argument to be a list of equations."), return(false)),
+ /* 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, <chris@sangwin.com> */
+/* 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)) )
+)$
+
diff --git a/stack/2014083000/maxima/mathml.lisp b/stack/2014083000/maxima/mathml.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7671dad91e31b7c9b9caf64c27e3891e2d73e4c0
--- /dev/null
+++ b/stack/2014083000/maxima/mathml.lisp
@@ -0,0 +1,762 @@
+(in-package "MAXIMA")
+;; MathML-printing
+;; Created by David Drysdale (DMD), December 2002/January 2003
+;;
+;; closely based on the original TeX conversion code in mactex.lisp,
+;; for which the following credits apply:
+;; (c) copyright 1987, Richard J. Fateman
+;; small corrections and additions: Andrey Grozin, 2001
+;; additional additions: Judah Milgram (JM), September 2001
+;; additional corrections: Barton Willis (BLW), October 2001
+
+;; Usage: mathml(d8,"/tmp/foo.xml"); mathml(d10,"/tmp/foo.xml"); ..
+;; to append lines d8 and d10 to the mathml file. If given only
+;; one argument the result goes to standard output.
+
+;; Method:
+
+;; Producing MathML from a macsyma internal expression is done by
+;; a reversal of the parsing process. Fundamentally, a
+;; traversal of the expression tree is produced by the program,
+;; with appropriate substitutions and recognition of the
+;; infix / prefix / postfix / matchfix relations on symbols. Various
+;; changes are made to this so that MathML will like the results.
+
+;; Instructions:
+;; in macsyma, type mathml(<expression>); or mathml(<label>); or
+;; mathml(<expr-or-label>, <file-name>); In the case of a label,
+;; an equation-number will also be produced.
+;; in case a file-name is supplied, the output will be sent
+;; (perhaps appended) to that file.
+
+(macsyma-module mathml)
+
+#+franz
+($bothcases t) ;; allow alpha and Alpha to be different
+(declare-top
+ (special lop rop ccol $gcprint texport $labels $inchar
+ vaxima-main-dir
+ )
+ (*expr mathml-lbp mathml-rbp))
+
+;; top level command the result of converting the expression x.
+
+(defmspec $mathml(l) ;; mexplabel, and optional filename
+ ;;if filename supplied but 'nil' then return a string
+ (let ((args (cdr l)))
+ (cond ((and (cdr args) (null (cadr args)))
+ (let ((*standard-output* (make-string-output-stream)))
+ (apply 'mathml1 args)
+ (get-output-stream-string *standard-output*)
+ )
+ )
+ (t (apply 'mathml1 args)))))
+
+(defun mathml1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
+ (prog (mexp texport $gcprint ccol x y itsalabel tmpport)
+ ;; $gcprint = nil turns gc messages off
+ (setq ccol 1)
+ (cond ((null mexplabel)
+ (displa " No eqn given to MathML")
+ (return nil)))
+ ;; collect the file-name, if any, and open a port if needed
+ (setq texport (cond((null filename) *standard-output* ); t= output to terminal
+ (t
+ (open (string (stripdollar filename))
+ :direction :output
+ :if-exists :append
+ :if-does-not-exist :create))))
+ ;; go back and analyze the first arg more thoroughly now.
+ ;; do a normal evaluation of the expression in macsyma
+ (setq mexp (meval mexplabel))
+ (cond ((memq mexplabel $labels); leave it if it is a label
+ (setq mexplabel (concat "(" (stripdollar mexplabel) ")"))
+ (setq itsalabel t))
+ (t (setq mexplabel nil)));flush it otherwise
+
+ ;; maybe it is a function?
+ (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
+ (setq x ($verbify x))
+ (cond ((setq y (mget x 'mexpr))
+ (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'mmacro))
+ (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'aexpr))
+ (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
+ (cond ((and (null (atom mexp))
+ (memq (caar mexp) '(mdefine mdefmacro)))
+ (format texport "<pre>~%" )
+ (cond (mexplabel (format texport "~a " mexplabel)))
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ ((and
+ itsalabel ;; but is it a user-command-label?
+ (eq (getchar $inchar 2) (getchar mexplabel 2)))
+ ;; aha, this is a C-line: do the grinding:
+ (format texport "<pre>~%~a " mexplabel)
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ (t ; display the expression for MathML now:
+ (myprinc "<math xmlns='http://www.w3.org/1998/Math/MathML'> ")
+ (mapc #'myprinc
+ ;;initially the left and right contexts are
+ ;; empty lists, and there are implicit parens
+ ;; around the whole expression
+ (mathml mexp nil nil 'mparen 'mparen))
+ (cond (mexplabel
+ (format texport "<mspace width='verythickmathspace'/> <mtext>~a</mtext> " mexplabel)))
+ (format texport "</math>")))
+ (cond(filename(terpri texport); and drain port if not terminal
+ (close texport)))
+ (return mexplabel)))
+
+(defun mathml (x l r lop rop)
+ ;; x is the expression of interest; l is the list of strings to its
+ ;; left, r to its right. lop and rop are the operators on the left
+ ;; and right of x in the tree, and will determine if parens must
+ ;; be inserted
+ (setq x (nformat x))
+ (cond ((atom x) (mathml-atom x l r))
+ ((or (<= (mathml-lbp (caar x)) (mathml-rbp lop))
+ (> (mathml-lbp rop) (mathml-rbp (caar x))))
+ (mathml-paren x l r))
+ ;; special check needed because macsyma notates arrays peculiarly
+ ((memq 'array (cdar x)) (mathml-array x l r))
+ ;; dispatch for object-oriented mathml-ifiying
+ ((get (caar x) 'mathml) (funcall (get (caar x) 'mathml) x l r))
+ (t (mathml-function x l r nil))))
+
+(defun string-substitute (newstring oldchar x &aux matchpos)
+ (setq matchpos (position oldchar x))
+ (if (null matchpos) x
+ (concatenate 'string
+ (subseq x 0 matchpos)
+ newstring
+ (string-substitute newstring oldchar (subseq x (1+ matchpos))))))
+
+;;; NOTE that we try to include spaces after closing tags (e.g. "</mwhatever> ")
+;;; so that the line breaking algorithm in myprinc has some spaces where it
+;;; can choose to line break.
+
+;;; First we have the functions which are called directly by mathml and its
+;;; descendents
+
+(defun mathml-atom (x l r)
+ (append l
+ (list (cond ((numberp x) (mathmlnumformat x))
+ ((mstringp x) (string-left-trim '(#\&) x))
+ ((and (symbolp x) (get x 'mathmlword)))
+ (t (mathml-stripdollar x))))
+ r))
+
+(defun mathmlnumformat(atom)
+ (let (r firstpart exponent)
+ (cond ((integerp atom)
+ (strcat "<mn>" (format nil "~d" atom) "</mn> "))
+ (t
+ (setq r (explode atom))
+ (setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
+ (cond ((null exponent)
+ ;; it is not. go with it as given
+ (strcat "<mn>" (format nil "~s" atom) "</mn> "))
+ (t
+ (setq firstpart
+ (nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
+ (strcat
+ "<mrow><mn>"
+ (apply #'strcat firstpart)
+ "</mn><mo>×</mo> <msup><mn>10</mn><mn>"
+ (apply #'strcat (cdr exponent))
+ "</mn></msup> </mrow> ")
+ ))))))
+
+(defun mathml-stripdollar(sym)
+ (or (symbolp sym)
+ (return-from mathml-stripdollar sym))
+ (let* ((pname (string-left-trim '(#\$) (symbol-name sym)))
+ (l (length pname))
+ (begin-sub
+ (loop for i downfrom (1- l)
+ when (not (digit-char-p (aref pname i)))
+ do (return (1+ i)))))
+ (cond ((< begin-sub l) ;; need to do subscripting
+ (strcat "<msub><mi>"
+ (subseq pname 0 begin-sub)
+ "</mi> <mn>"
+ (subseq pname begin-sub l)
+ "</mn></msub> "))
+ (t ;; no subscripting needed
+ (strcat "<mi>" pname "</mi> ")))))
+
+(defun mathml-paren (x l r)
+ (mathml x (append l '("<mfenced separators=''>")) (cons "</mfenced> " r) 'mparen 'mparen))
+
+(defun mathml-array (x l r)
+ (let ((f))
+ (if (eq 'mqapply (caar x))
+ (setq f (cadr x)
+ x (cdr x)
+ l (mathml f (append l (list "<mfenced separators=','>"))
+ (list "</mfenced> ") 'mparen 'mparen))
+ (setq f (caar x)
+ l (mathml (mathmlword f) (append l '("<msub><mrow>")) nil lop 'mfunction)))
+ (setq
+ r (nconc (mathml-list (cdr x) nil (list "</mrow></msub> ") "<mo>,</mo>") r))
+ (nconc l (list "</mrow><mrow>") r )))
+
+;; set up a list , separated by symbols (, * ...) and then tack on the
+;; ending item (e.g. "]" or perhaps ")"
+(defun mathml-list (x l r sym)
+ (if (null x) r
+ (do ((nl))
+ ((null (cdr x))
+ (setq nl (nconc nl (mathml (car x) l r 'mparen 'mparen)))
+ nl)
+ (setq nl (nconc nl (mathml (car x) l (list sym) 'mparen 'mparen))
+ x (cdr x)
+ l nil))))
+
+;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
+;; operator
+(defun mathml-function (x l r op) op
+ (setq l (mathml (mathmlword (caar x)) l nil 'mparen 'mparen)
+ r (mathml (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
+ (nconc l r))
+
+;;; Now we have functions which are called via property lists
+
+(defun mathml-prefix (x l r)
+ (mathml (cadr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-infix (x l r)
+ ;; check for 2 args
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) l nil lop (caar x)))
+ (mathml (caddr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-postfix (x l r)
+ (mathml (cadr x) l (append (mathmlsym (caar x)) r) lop (caar x)))
+
+(defun mathml-nary (x l r)
+ (let* ((op (caar x)) (sym (mathmlsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
+ (cond ((null y) (mathml-function x l r t)) ; this should not happen
+ ((null (cdr y)) (mathml-function x l r t)) ; this should not happen, too
+ (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
+ ((null (cdr y)) (setq nl (nconc nl (mathml (car y) l r lop rop))) nl)
+ (setq nl (nconc nl (mathml (car y) l (list sym) lop rop))
+ y (cdr y)
+ l nil))))))
+
+(defun mathml-nofix (x l r) (mathml (caar x) l r (caar x) rop))
+
+(defun mathml-matchfix (x l r)
+ (setq l (append l (car (mathmlsym (caar x))))
+ ;; car of mathmlsym of a matchfix operator is the lead op
+ r (append (cdr (mathmlsym (caar x))) r)
+ ;; cdr is the trailing op
+ x (mathml-list (cdr x) nil r "<mo>,</mo>"))
+ (append l x))
+
+(defun mathmlsym (x) (or (get x 'mathmlsym) (get x 'strsym)(get x 'dissym)
+ (stripdollar x)))
+
+(defun mathmlword (x)(or (get x 'mathmlword) (stripdollar x)))
+
+(defprop bigfloat mathml-bigfloat mathml)
+
+(defun mathml-bigfloat (x l r) (declare (ignore l r)) (fpformat x))
+
+(defprop mprog "<mi>block</mi><mspace width='mediummathspace'/> " mathmlword)
+(defprop %erf "<mi>erf</mi> " mathmlword)
+(defprop $erf "<mi>erf</mi> " mathmlword) ;; etc for multicharacter names
+(defprop $true "<mi>true</mi> " mathmlword)
+(defprop $false "<mi>false</mi> " mathmlword)
+
+(defprop mprogn mathml-matchfix mathml) ;; mprogn is (<progstmnt>, ...)
+(defprop mprogn (("<mfenced separators=''>") "</mfenced> ") mathmlsym)
+
+(defprop mlist mathml-matchfix mathml)
+(defprop mlist (("<mfenced separators='' open='[' close=']'>")"</mfenced> ") mathmlsym)
+
+;;absolute value
+(defprop mabs mathml-matchfix mathml)
+(defprop mabs (("<mfenced separators='' open='|' close='|'>")"</mfenced> ") mathmlsym)
+
+(defprop mqapply mathml-mqapply mathml)
+
+(defun mathml-mqapply (x l r)
+ (setq l (mathml (cadr x) l (list "(" ) lop 'mfunction)
+ r (mathml-list (cddr x) nil (cons ")" r) "<mo>,</mo>"))
+ (append l r));; fixed 9/24/87 RJF
+
+(defprop $%i "<mi>ⅈ</mi> " mathmlword)
+(defprop $%pi "<mi>π</mi> " mathmlword)
+(defprop $%e "<mi>ⅇ</mi> " mathmlword)
+(defprop $inf "<mi>∞</mi> " mathmlword)
+(defprop $minf "<mi>-∞</mi> " mathmlword)
+(defprop %laplace "<mo>ℒ</mo>" mathmlword)
+(defprop $alpha "<mi>α</mi> " mathmlword)
+(defprop $beta "<mi>β</mi> " mathmlword)
+(defprop $gamma "<mi>γ</mi> " mathmlword)
+(defprop %gamma "<mi>Γ</mi> " mathmlword)
+(defprop $delta "<mi>δ</mi> " mathmlword)
+(defprop $epsilon "<mi>ε</mi> " mathmlword)
+(defprop $zeta "<mi>ζ</mi> " mathmlword)
+(defprop $eta "<mi>η</mi> " mathmlword)
+(defprop $theta "<mi>θ</mi> " mathmlword)
+(defprop $iota "<mi>ι</mi> " mathmlword)
+(defprop $kappa "<mi>κ</mi> " mathmlword)
+;(defprop $lambda "<mi>λ</mi> " mathmlword)
+(defprop $mu "<mi>μ</mi> " mathmlword)
+(defprop $nu "<mi>ν</mi> " mathmlword)
+(defprop $xi "<mi>ξ</mi> " mathmlword)
+(defprop $pi "<mi>π</mi> " mathmlword)
+(defprop $rho "<mi>ρ</mi> " mathmlword)
+(defprop $sigma "<mi>σ</mi> " mathmlword)
+(defprop $tau "<mi>τ</mi> " mathmlword)
+(defprop $upsilon "<mi>υ</mi> " mathmlword)
+(defprop $phi "<mi>φ</mi> " mathmlword)
+(defprop $chi "<mi>χ</mi> " mathmlword)
+(defprop $psi "<mi>ψ</mi> " mathmlword)
+(defprop $omega "<mi>ω</mi> " mathmlword)
+
+(defprop mquote mathml-prefix mathml)
+(defprop mquote ("<mo>'</mo>") mathmlsym)
+(defprop mquote 201. mathml-rbp)
+
+(defprop msetq mathml-infix mathml)
+(defprop msetq ("<mo>:</mo>") mathmlsym)
+(defprop msetq 180. mathml-rbp)
+(defprop msetq 20. mathml-rbp)
+
+(defprop mset mathml-infix mathml)
+(defprop mset ("<mo>::</mo>") mathmlsym)
+(defprop mset 180. mathml-lbp)
+(defprop mset 20. mathml-rbp)
+
+(defprop mdefine mathml-infix mathml)
+(defprop mdefine ("<mo>:=</mo>") mathmlsym)
+(defprop mdefine 180. mathml-lbp)
+(defprop mdefine 20. mathml-rbp)
+
+(defprop mdefmacro mathml-infix mathml)
+(defprop mdefmacro ("<mo>::=</mo>") mathmlsym)
+(defprop mdefmacro 180. mathml-lbp)
+(defprop mdefmacro 20. mathml-rbp)
+
+(defprop marrow mathml-infix mathml)
+(defprop marrow ("<mo>→</mo>") mathmlsym)
+(defprop marrow 25 mathml-lbp)
+(defprop marrow 25 mathml-rbp)
+
+(defprop mfactorial mathml-postfix mathml)
+(defprop mfactorial ("<mo>!</mo>") mathmlsym)
+(defprop mfactorial 160. mathml-lbp)
+
+(defprop mexpt mathml-mexpt mathml)
+(defprop mexpt 140. mathml-lbp)
+(defprop mexpt 139. mathml-rbp)
+
+(defprop %sum 110. mathml-rbp) ;; added by BLW, 1 Oct 2001
+(defprop %product 115. mathml-rbp) ;; added by BLW, 1 Oct 2001
+
+;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
+(defun mathml-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
+ (memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
+ (not (memq f '(%sum %product %derivative %integrate %at
+ %lsum %limit))) ;; 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 (mathml `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
+ (if (and (null (cdr bascdr))
+ (eq (get f 'mathml) 'mathml-prefix))
+ (setq r (mathml (car bascdr) nil r f 'mparen))
+ (setq r (mathml (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
+ (t nil))))) ; won't doit. fall through
+ (t (setq l (mathml (cadr x) (append l '("<msup><mrow>")) nil lop (caar x))
+ r (if (mmminusp (setq x (nformat (caddr x))))
+ ;; the change in base-line makes parens unnecessary
+ (if nc
+ (mathml (cadr x) '("</mrow> <mfenced separators='' open='<' close='>'> -")(cons "</mfenced></msup> " r) 'mparen 'mparen)
+ (mathml (cadr x) '("</mrow> <mfenced separators=''> -")(cons "</mfenced></msup> " r) 'mparen 'mparen))
+ (if nc
+ (mathml x (list "</mrow> <mfenced separators='' open='<' close='>'>")(cons "</mfenced></msup>" r) 'mparen 'mparen)
+ (if (and (numberp x) (< x 10))
+ (mathml x (list "</mrow> ")(cons "</msup> " r) 'mparen 'mparen)
+ (mathml x (list "</mrow> <mrow>")(cons "</mrow><mrow> " r) 'mparen 'mparen))
+ )))))
+ (append l r)))
+
+(defprop mncexpt mathml-mexpt mathml)
+
+(defprop mncexpt 135. mathml-lbp)
+(defprop mncexpt 134. mathml-rbp)
+
+(defprop mnctimes mathml-nary mathml)
+(defprop mnctimes "<mi>⋯</mi> " mathmlsym)
+(defprop mnctimes 110. mathml-lbp)
+(defprop mnctimes 109. mathml-rbp)
+
+(defprop mtimes mathml-nary mathml)
+(defprop mtimes "<mspace width='thinmathspace'/>" mathmlsym)
+(defprop mtimes 120. mathml-lbp)
+(defprop mtimes 120. mathml-rbp)
+
+(defprop %sqrt mathml-sqrt mathml)
+
+(defun mathml-sqrt(x l r)
+ ;; format as \\sqrt { } assuming implicit parens for sqr grouping
+ (mathml (cadr x) (append l '("<msqrt>")) (append '("</msqrt>") r) 'mparen 'mparen))
+
+;; macsyma doesn't know about cube (or nth) roots,
+;; but if it did, this is what it would look like.
+(defprop $cubrt mathml-cubrt mathml)
+
+(defun mathml-cubrt (x l r)
+ (mathml (cadr x) (append l '("<mroot><mrow>")) (append '("</mrow>3</mroot>") r) 'mparen 'mparen))
+
+(defprop mquotient mathml-mquotient mathml)
+(defprop mquotient ("<mo>/</mo>") mathmlsym)
+(defprop mquotient 122. mathml-lbp) ;;dunno about this
+(defprop mquotient 123. mathml-rbp)
+
+(defun mathml-mquotient (x l r)
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) (append l '("<mfrac><mrow>")) nil 'mparen 'mparen)
+ r (mathml (caddr x) (list "</mrow> <mrow>") (append '("</mrow></mfrac> ")r) 'mparen 'mparen))
+ (append l r))
+
+(defprop $matrix mathml-matrix mathml)
+
+(defun mathml-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
+ (append l `("<mfenced separators='' open='(' close=')'><mtable>")
+ (mapcan #'(lambda(y)
+ (mathml-list (cdr y) (list "<mtr><mtd>") (list "</mtd></mtr> ") "</mtd><mtd>"))
+ (cdr x))
+ '("</mtable></mfenced> ") r))
+
+;; macsyma sum or prod is over integer range, not low <= index <= high
+;; Mathml is lots more flexible .. but
+
+(defprop %sum mathml-sum mathml)
+(defprop %lsum mathml-lsum mathml)
+(defprop %product mathml-sum mathml)
+
+;; easily extended to union, intersect, otherops
+
+(defun mathml-lsum(x l r)
+ (let ((op (cond ((eq (caar x) '%lsum) "<mrow><munder><mo>∑</mo> <mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow></munder> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defun mathml-sum(x l r)
+ (let ((op (cond ((eq (caar x) '%sum) "<mrow><munderover><mo>∑</mo><mrow>")
+ ((eq (caar x) '%product) "<mrow><munderover><mo>∏</mo><mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
+ (toplim (mathml (car(cddddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow> <mrow>" ,@toplim "</mrow></munderover> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defprop %integrate mathml-int mathml)
+
+(defun mathml-int (x l r)
+ (let ((s1 (mathml (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
+ (var (mathml (caddr x) nil nil 'mparen rop))) ;; variable
+ (cond((= (length x) 3)
+ (append l `("<mrow><mo>∫</mo><mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi></mrow></mrow> ") r))
+ (t ;; presumably length 5
+ (let ((low (mathml (nth 3 x) nil nil 'mparen 'mparen))
+ ;; 1st item is 0
+ (hi (mathml (nth 4 x) nil nil 'mparen 'mparen)))
+ (append l `("<mrow><munderover><mo>∫</mo> <mrow>" ,@low "</mrow> <mrow>" ,@hi "</mrow> </munderover> <mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi> </mrow></mrow> ") r))))))
+
+(defprop %limit mathml-limit mathml)
+
+(defprop mrarr mathml-infix mathml)
+(defprop mrarr ("<mo>→</mo> ") mathmlsym)
+(defprop mrarr 80. mathml-lbp)
+(defprop mrarr 80. mathml-rbp)
+
+(defun mathml-limit(x l r) ;; ignoring direction, last optional arg to limit
+ (let ((s1 (mathml (second x) nil nil 'mparen rop));; limitfunction
+ (subfun ;; the thing underneath "limit"
+ (mathml `((mrarr simp) ,(third x) ,(fourth x)) nil nil 'mparen 'mparen)))
+ (append l `("<munder><mo>lim</mo><mrow>" ,@subfun "</mrow> </munder> <mrow>" ,@s1 "</mrow>") r)))
+
+(defprop %at mathml-at mathml)
+
+;; e.g. at(diff(f(x)),x=a)
+(defun mathml-at (x l r)
+ (let ((s1 (mathml (cadr x) nil nil lop rop))
+ (sub (mathml (caddr x) nil nil 'mparen 'mparen)))
+ (append l '("<msub><mfenced separators='' open='' close='|'>") s1 '("</mfenced> <mrow>") sub '("</mrow> </msub> ") r)))
+
+;;binomial coefficients
+
+(defprop %binomial mathml-choose mathml)
+
+(defun mathml-choose (x l r)
+ `(,@l
+ "<mfenced separators='' open='(' close=')'><mtable><mtr><mtd>"
+ ,@(mathml (cadr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> <mtr><mtd>"
+ ,@(mathml (caddr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> </mtable></mfenced> "
+ ,@r))
+
+
+(defprop rat mathml-rat mathml)
+(defprop rat 120. mathml-lbp)
+(defprop rat 121. mathml-rbp)
+(defun mathml-rat(x l r) (mathml-mquotient x l r))
+
+(defprop mplus mathml-mplus mathml)
+(defprop mplus 100. mathml-lbp)
+(defprop mplus 100. mathml-rbp)
+
+(defun mathml-mplus (x l r)
+ ;(declare (fixnum w))
+ (cond ((memq 'trunc (car x))(setq r (cons "<mo>+</mo><mtext>⋯</mtext> " r))))
+ (cond ((null (cddr x))
+ (if (null (cdr x))
+ (mathml-function x l r t)
+ (mathml (cadr x) (cons "<mo>+</mo>" l) r 'mplus rop)))
+ (t (setq l (mathml (cadr x) l nil lop 'mplus)
+ x (cddr x))
+ (do ((nl l) (dissym))
+ ((null (cdr x))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq r (mathml l dissym r 'mplus rop))
+ (append nl r))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq nl (append nl (mathml l dissym nil 'mplus 'mplus))
+ x (cdr x))))))
+
+(defprop mminus mathml-prefix mathml)
+(defprop mminus ("-") mathmlsym)
+(defprop mminus 100. mathml-rbp)
+(defprop mminus 100. mathml-lbp)
+
+(defprop min mathml-infix mathml)
+(defprop min ("<mo>∈</mo> ") mathmlsym)
+(defprop min 80. mathml-lbp)
+(defprop min 80. mathml-rbp)
+
+(defprop mequal mathml-infix mathml)
+(defprop mequal ("<mo>=</mo> ") mathmlsym)
+(defprop mequal 80. mathml-lbp)
+(defprop mequal 80. mathml-rbp)
+
+(defprop mnotequal mathml-infix mathml)
+(defprop mnotequal 80. mathml-lbp)
+(defprop mnotequal 80. mathml-rbp)
+
+(defprop mgreaterp mathml-infix mathml)
+(defprop mgreaterp ("<mo>></mo> ") mathmlsym)
+(defprop mgreaterp 80. mathml-lbp)
+(defprop mgreaterp 80. mathml-rbp)
+
+(defprop mgeqp mathml-infix mathml)
+(defprop mgeqp ("<mo>≥</mo> ") mathmlsym)
+(defprop mgeqp 80. mathml-lbp)
+(defprop mgeqp 80. mathml-rbp)
+
+(defprop mlessp mathml-infix mathml)
+(defprop mlessp ("<mo><</mo> ") mathmlsym)
+(defprop mlessp 80. mathml-lbp)
+(defprop mlessp 80. mathml-rbp)
+
+(defprop mleqp mathml-infix mathml)
+(defprop mleqp ("<mo>≤</mo> ") mathmlsym)
+(defprop mleqp 80. mathml-lbp)
+(defprop mleqp 80. mathml-rbp)
+
+(defprop mnot mathml-prefix mathml)
+(defprop mnot ("<mo>¬</mo> ") mathmlsym)
+(defprop mnot 70. mathml-rbp)
+
+(defprop mand mathml-nary mathml)
+(defprop mand ("<mo>∧</mo> ") mathmlsym)
+(defprop mand 60. mathml-lbp)
+(defprop mand 60. mathml-rbp)
+
+(defprop mor mathml-nary mathml)
+(defprop mor ("<mo>∨</mo> ") mathmlsym)
+
+;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
+;; etc
+
+(defun mathml-setup (x)
+ (let((a (car x))
+ (b (cadr x)))
+ (setf (get a 'mathml) 'mathml-prefix)
+ (setf (get a 'mathmlword) b) ;This means "sin" will always be roman
+ (setf (get a 'mathmlsym) (list b))
+ (setf (get a 'mathml-rbp) 130)))
+
+(mapc #'mathml-setup
+ '(
+ (%acos "<mi>arccos</mi> ")
+ (%asin "<mi>arcsin</mi> ")
+ (%atan "<mi>arctan</mi> ")
+ (%arg "<mi>arg</mi> ")
+ (%cos "<mi>cos</mi> ")
+ (%cosh "<mi>cosh</mi> ")
+ (%cot "<mi>cot</mi> ")
+ (%coth "<mi>coth</mi> ")
+ (%csc "<mi>cosec</mi> ")
+ (%deg "<mi>deg</mi> ")
+ (%determinant "<mi>det</mi> ")
+ (%dim "<mi>dim</mi> ")
+ (%exp "<mi>exp</mi> ")
+ (%gcd "<mi>gcd</mi> ")
+ (%hom "<mi>hom</mi> ")
+ (%inf "<mi>∞</mi> ")
+ (%ker "<mi>ker</mi> ")
+ (%lg "<mi>lg</mi> ")
+ ;;(%limit "<mi>lim</mi> ")
+ (%liminf "<mi>lim inf</mi> ")
+ (%limsup "<mi>lim sup</mi> ")
+ (%ln "<mi>ln</mi> ")
+ (%log "<mi>log</mi> ")
+ (%max "<mi>max</mi> ")
+ (%min "<mi>min</mi> ")
+ ; Latex's "Pr" ... ?
+ (%sec "<mi>sec</mi> ")
+ (%sech "<mi>sech</mi> ")
+ (%sin "<mi>sin</mi> ")
+ (%sinh "<mi>sinh</mi> ")
+ (%sup "<mi>sup</mi> ")
+ (%tan "<mi>tan</mi> ")
+ (%tanh "<mi>tanh</mi> ")
+ ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
+ ;(%laplace "{\\cal L}")
+ )) ;; etc
+
+(defprop mor mathml-nary mathml)
+(defprop mor 50. mathml-lbp)
+(defprop mor 50. mathml-rbp)
+
+(defprop mcond mathml-mcond mathml)
+(defprop mcond 25. mathml-lbp)
+(defprop mcond 25. mathml-rbp)
+
+(defprop %derivative mathml-derivative mathml)
+
+(defun mathml-derivative (x l r)
+ (mathml (mathml-d x "ⅆ") l r lop rop ))
+
+(defun mathml-d(x dsym) ;dsym should be "ⅆ" or "∂"
+ ;; 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '(mtimes)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mtimes)
+ ((mquotient) ,(simplifya numer nil) ,denom)
+ ,arg)))
+
+(defun mathml-mcond (x l r)
+ (append l
+ (mathml (cadr x) '("<mi>if</mi> <mspace width='mediummathspace'/>")
+ '("<mspace width='mediummathspace'/> <mi>then</mi><mspace width='mediummathspace'/> ") 'mparen 'mparen)
+ (if (eql (fifth x) '$false)
+ (mathml (caddr x) nil r 'mcond rop)
+ (append (mathml (caddr x) nil nil 'mparen 'mparen)
+ (mathml (fifth x) '("<mspace width='mediummathspace'/> <mi>else</mi><mspace width='mediummathspace'/> ") r 'mcond rop)))))
+
+(defprop mdo mathml-mdo mathml)
+(defprop mdo 30. mathml-lbp)
+(defprop mdo 30. mathml-rbp)
+(defprop mdoin mathml-mdoin mathml)
+(defprop mdoin 30. mathml-rbp)
+
+(defun mathml-lbp(x)(cond((get x 'mathml-lbp))(t(lbp x))))
+(defun mathml-rbp(x)(cond((get x 'mathml-rbp))(t(lbp x))))
+
+;; these aren't quite right
+
+(defun mathml-mdo (x l r)
+ (mathml-list (mathmlmdo x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathml-mdoin (x l r)
+ (mathml-list (mathmlmdoin x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathmlmdo (x)
+ (nconc (cond ((second x) `("<mi>for</mi> " ,(second x))))
+ (cond ((equal 1 (third x)) nil)
+ ((third x) `("<mi>from</mi> " ,(third x))))
+ (cond ((equal 1 (fourth x)) nil)
+ ((fourth x) `("<mi>step</mi> " ,(fourth x)))
+ ((fifth x) `("<mi>next</mi> " ,(fifth x))))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+(defun mathmlmdoin (x)
+ (nconc `("<mi>for</mi>" ,(second x) "<mi>in</mi> " ,(third x))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+;; Undone and trickier:
+;; Maybe do some special hacking for standard notations for
+;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
diff --git a/stack/2014083000/maxima/multiply_cross.lisp b/stack/2014083000/maxima/multiply_cross.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ec0052c83f44c454a238de0e579d79121ebf2f3b
--- /dev/null
+++ b/stack/2014083000/maxima/multiply_cross.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\times ") texsym)
diff --git a/stack/2014083000/maxima/multiply_dot.lisp b/stack/2014083000/maxima/multiply_dot.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fb7cb69891f68486972dd35d406fe5a2b79fe1f8
--- /dev/null
+++ b/stack/2014083000/maxima/multiply_dot.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\cdot ") texsym)
diff --git a/stack/2014083000/maxima/noun_arith.lisp b/stack/2014083000/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..929a906f5ffa346f3e2121abb254f5e8e00a4615
--- /dev/null
+++ b/stack/2014083000/maxima/noun_arith.lisp
@@ -0,0 +1,28 @@
+;; 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)
diff --git a/stack/2014083000/maxima/rtest_assessment_simpboth.mac b/stack/2014083000/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..5e47a7f79e1b98d256a280d3396905ed8f43a24c
--- /dev/null
+++ b/stack/2014083000/maxima/rtest_assessment_simpboth.mac
@@ -0,0 +1,297 @@
+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);
+1^2+x^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$
+
+
diff --git a/stack/2014083000/maxima/rtest_assessment_simpfalse.mac b/stack/2014083000/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..edf6677166c538584ec847a9ee181d03b2c5c4f4
--- /dev/null
+++ b/stack/2014083000/maxima/rtest_assessment_simpfalse.mac
@@ -0,0 +1,121 @@
+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$
+
+factorlist(15);
+[3,5]$
+factorlist(x^3-1);
+[x-1,1+x+x^2]$
+
+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)$
+
diff --git a/stack/2014083000/maxima/rtest_assessment_simptrue.mac b/stack/2014083000/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..ddccba9a55d3c7db5c4531598c994e6da3d94d8d
--- /dev/null
+++ b/stack/2014083000/maxima/rtest_assessment_simptrue.mac
@@ -0,0 +1,20 @@
+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)$
diff --git a/stack/2014083000/maxima/rtest_elementary.mac b/stack/2014083000/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2014083000/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/2014083000/maxima/rtest_experimental.mac b/stack/2014083000/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..9ed077a34f2e57a02fdf21d6291b99b66a42b22a
--- /dev/null
+++ b/stack/2014083000/maxima/rtest_experimental.mac
@@ -0,0 +1,104 @@
+linear_inequalityp(x>1);
+true$
+
+linear_inequalityp(x>=1);
+true$
+
+linear_inequalityp(x=1);
+false$
+
+linear_inequalityp(x);
+false$
+
+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$
+
+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]$
+
+interval_inequalityp(true);
+true$
+interval_inequalityp(false);
+true$
+interval_inequalityp(x>1);
+true$
+interval_inequalityp(1<x and x<%pi);
+true$
+interval_inequalityp(1<x and y<%pi);
+false$
+interval_inequalityp(x<1 or x>7);
+false$
+interval_inequalityp(1<x and x<%pi and x<20);
+true$
+
+rev_ineq(x>6);
+6<x;
+rev_ineq(x>=6);
+6<=x;
+rev_ineq(x^2<x);
+x>x^2;
+rev_ineq(x);
+x;
+
+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$
+
+interval_simplify(x>4 and x>7);
+7<x$
+interval_simplify(1<x and x<7);
+1<x and x<7$
+interval_simplify(1<x and 7>x);
+1<x and x<7$
+interval_simplify(x>4 and x<1);
+false;
+
+
+factor_ineq_solve((x-1)^2<=-1);
+false;
+factor_ineq_solve(x^2>=4);
+x <= -2 or 2 <= x$
+factor_ineq_solve(x^2<=4);
+-2 <= x and x <= 2$
+factor_ineq_solve(x^4-5*x^2>-4);
+(x < -2) or (-1 < x and x < 1) or (2 < x)$
+factor_ineq_solve(x^4-5*x^2<=-4);
+(1 <= x and x <= 2) or (-2 <= x and x <= -1);
diff --git a/stack/2014083000/maxima/stackmaxima.mac b/stack/2014083000/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..a3bcb66268795e30afcf4cad465a826c7ca6047d
--- /dev/null
+++ b/stack/2014083000/maxima/stackmaxima.mac
@@ -0,0 +1,2293 @@
+/* Author Chris Sangwin
+ Loughborough University
+ Copyright (C) 2014 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(rand_seed) := block(
+ kill(allbut [functions]),
+ kill(trigsimp),
+ /* We need some kind of numerical number to compare against. */
+ /* This does not work in Maxima 5.13.0, but keep for future reference */
+ /* MAXIMA_VERSION_NUM:parse_string(?subseq(MAXIMA_VERSION,2)) */
+ /* */
+ simpsum:true,
+ negdistrib:true, /* When negdistrib is true, -1 distributes over an expression. E.g., -(x + y) becomes - y - x. */
+ display2d:false,
+ nolabels:true,
+ logabs:true,
+ exptdispflag:true,
+ linsolvewarn:false,
+ ratprint: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),
+
+ /*Reload local settings*/
+ STACK_SETUP(true),
+
+ MAXIMA_VERSION:map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp)),
+ MAXIMA_VERSION_NUM:float(MAXIMA_VERSION[2]+MAXIMA_VERSION[3]/10),
+
+ /* */
+ OPT_OUTPUT:"LaTeX",
+ /* */
+ DIV_OP:"//",
+ if MAXIMA_VERSION_NUM>=15.0 then DIV_OP:"/",
+
+ 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(1000);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* 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*/
+
+
+/* ********************************** */
+/* Logarithms */
+/* ********************************** */
+alias(ln, log);
+load("log10");
+texput(log10, "\\log\\mathrm{10}", prefix);
+alias(lg, log10);
+texput(lg, "\\mathrm{lg}", prefix);
+load ("functs");
+
+/* We don't want to allow people to put boxes round things. */
+box(ex):=ex;
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+/* 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("expandfeedback.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"); /* Currently part of the STACK distribution */
+
+load("stacktex.lisp"); /* Loads LaTeX changes and preferences */
+texput(QMCHAR, "\\color{red}{?}");
+
+alias(arccos, acos); /* At the request of the OU, 4 Feb 2013 */
+alias(arcsin, asin);
+alias(arctan, atan);
+
+load("mathml.lisp"); /* loads MathML */
+
+
+make_complexJ(OPT_COMPLEXJ) := block(
+ if OPT_COMPLEXJ = "i" then
+ (i:%i,load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "j" then
+ (%j:%i,j:%i,load("complexj.lisp"))
+ else if OPT_COMPLEXJ = "symi" then
+ (load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "symj" then
+ (load("complexj.lisp"))
+ else true
+);
+
+/* Makes multiplication signs look correct */
+make_multsgn(OPT_MULTSGN) := block(
+ if OPT_MULTSGN = "cross" then load("multiply_cross.lisp"),
+ if OPT_MULTSGN = "dot" then load("multiply_dot.lisp")
+);
+
+/* Options for cos^(-1), acos or arccos */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then load("cos-1.lisp"),
+ if OPT_ACOS = "arccos" then load("arccos.lisp")
+);
+
+
+/* ****************************************************** */
+/* 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))
+)$
+
+randlist(ex) := block(
+ if (length(ex) > 0) then return(ev(ex[(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(step_parameter*temprand+lower)
+)$
+
+/* 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],
+ currents:ev((makelist(i, i, lower, upper)), simp),
+ for i:1 thru length(list) do block(
+ currents:simplify(delete(list[i], currents))
+ ),
+ retVal:rand(currents),
+ return(retVal)
+)$
+
+/* ********************************** */
+/* Display */
+/* ********************************** */
+/* expr - expression to be displayed */
+/* m - mode, either */
+/* "i" inline or */
+/* "d" for displayed, or */
+/* "" for no delimiters. */
+
+StackDISP(expr,m) := block([str:""],
+ /* LaTeX display */
+ if OPT_OUTPUT = "LaTeX" then
+ if not(ev(elementp(m, {"", "i", "d"}), simp)) then print(concat("ERROR: illegal delimiter option found: ", m)),
+ str:block([expru, expstr, offset, ld, rd],
+ ld:"",
+ rd:"",
+ if m = "i" then block(ld:"\\(", rd:"\\)"),
+ if m = "d" then block(ld:"\\[", rd:"\\]"),
+ expru:unary_minus_sort(expr),
+ expstr:tex(expru, false),
+ /* Remove $$'s from Maxima's TEX command */
+ if ?subseq(expstr, 0, 2) = "$$" then
+ expstr:concat(ld, ?subseq(expstr, 2, ev(?length(expstr)-3, simp)), rd)
+ /* Remove \begin{verbatim}'s from Maxima's TEX command */
+ else if ?length(expstr) > 17 and ?subseq(expstr,1,17) = "\\begin{verbatim}" then
+ expstr:concat(ld, ?subseq(expstr, 18, ev(?length(expstr)-18, simp)), rd),
+ expstr
+ ),
+ /* MathML display */
+ if OPT_OUTPUT = "MathML" then
+ str:mathml(expr, false),
+ /* 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)
+)$
+
+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) = "/" then return(detexcolor(argsex[1])/detexcolor(argsex[2])),
+ map(detexcolor, ex)
+)$
+
+detexdecorate(ex) := block([argsex],
+ if mapatom(ex) then return(ex),
+ argsex:args(ex),
+ if op(ex) = texdecorate then return(detexdecorate(argsex[2])),
+ if op(ex) = "/" then return(detexdecorate(argsex[1])/detexdecorate(argsex[2])),
+ map(detexdecorate, ex)
+)$
+
+/* Assume all non-numeric atoms are to be displayed in bold. */
+texboldatoms(ex) := block(
+ if numberp(ex) then return(ex),
+ if atom(ex) then return(texdecorate("\\bf", ex)),
+ apply(op(ex), maplist(texboldatoms, args(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 (print("\\mbox{ERROR: argument to stack_matrix_disp must be a matrix.} "), return("")),
+ if not(stringp(lmxchar)) then (print("\\mbox{ERROR: stack_matrix_disp requires lmxchar to be a string. }"), return("")),
+ parens:sublist(stack_matrix_pairs, lambda([ex],is(first(ex)=lmxchar))),
+ if emptyp(parens) then (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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(
+ if mapatom(ex) then return(ex),
+ if op(ex) = "-" and numberp(first(args(ex))) then return(ev(ex,simp)),
+ 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 mapatom(ex) then return(ex),
+ ex2:apply(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 mapatom(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 mapatom(ex) then return(ex),
+ if op(ex) = ":=" then return(ex),
+ ex2:unary_minus_traverse(ex),
+ return(unary_minus_pull(ex2))
+)$
+
+
+
+/* ****************************************************************** */
+/* 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("], display = ["),
+ print(StackDISP(ex[1], "")),
+ print("]"),
+ ex:ex[1]
+ ),
+ print("], "),
+ return(ex)
+)$
+
+/* ********************************** */
+/* Generate feedback */
+/* ********************************** */
+
+StackAddFeedback(fb, key, [ex]) := block([str, exprs, j],
+ /* 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 j:1 thru length(ex) do
+ /* HACK: !quot! needs to be replaced with " when we get into PHP. */
+ exprs:concat(exprs, " , !quot!", ex[j], "!quot! "), simp),
+ str:concat(fb, "stack_trans('", key, "'", exprs, "); "),
+ return(str)
+)$
+
+/* Separate notes with puncutation, to enable clearer reading
+ and the possibility to split them. */
+StackAddNote(exnote, 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)]$
+
+/* ********************************************************* */
+/* Turns answertest output to a STACK return object string */
+/* */
+/* ex[1] = validity should be true/false */
+/* ex[2] = result should be true/false, */
+/* ex[3] = feedback, a string */
+/* ex[4] = answernote, is for teacher stats */
+/* */
+/* ********************************************************* */
+
+StackReturn(ex) := block([str],
+ if not(listp(ex)) then (print("StackReturn failed: argument not a list: "), print(string(ex)), return("")),
+ if length(ex)#4 then (print("StackReturn failed: argument wrong length: "), print(string(ex)), return("")),
+ print(" ], valid = [ "),
+ if ex[1] then print(1) else print(0),
+ print(" ], answernote = [ "),
+ print(ex[3]),
+ print(" ], feedback = [ "),
+ print(ex[4]),
+ return(ex[2])
+)$
+
+/* 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 */
+/* ******************************************* */
+
+stack_validate(expr, ForbidFloats, LowestTerms, TAns) := block( [simp:false, exs, SameType],
+ /* Try to simply the expression to catch CAS errors */
+ exs:errcatch(ev(expr, simp)),
+ if exs=[] then return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError",string(expr), string(setify(expr)))),
+ expr:first(expr),
+ /* Check for floats, and if there are any then throw an error */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* Check if the student's answer is the same type as the Teachers */
+ SameType:ATSameTypefun(expr, TAns),
+ if SameType[2]#true then print(SameType[4]),
+ /* Now display the result */
+ simp:false,
+ expr:detexcolor(expr),
+ expr:detexdecorate(expr),
+ return(expr)
+)$
+
+/* Validate an expression without type checking. Floats and mathematical errors only. */
+stack_validate_typeless(expr, ForbidFloats, LowestTerms) := block( [simp:false, exs],
+ /* Try to simply the expression to catch CAS errors */
+ exs:errcatch(ev(expr, simp)),
+ if exs = [] then return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", expr, setify(expr))),
+ expr:first(expr),
+ /* Check for floats, and if there are any then throw an error */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* 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)
+)$
+
+/* These functions convert all variables in an expression to products of single letter variable names. */
+stack_singlevar_make_helper(ex) := block([s],
+ s:maplist(eval_string, charlist(string(ex))),
+ apply("*", s)
+)$
+
+stack_singlevar_make(ex) := block([vars, subs],
+ vars:sublist(listofvars(ex), lambda([ex], if slength(string(ex))>1 then true else false)),
+ if emptyp(vars) then return(ex),
+ vars:maplist(lambda([ex], ex=stack_singlevar_make_helper(ex)), vars),
+ sublis(vars, 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, afn, ufn, lvs, preamble, sysp, sysr, filename, tn, alt, altc, alttext, ral, ralforbid, pltargs, plotfunmake],
+ /* 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),
+ lvs:listofvars(ex),
+ lvs:sublist(lvs,lambda([ex],not(ex=discrete or ex=parametric))),
+ if length(lvs)>1 then
+ (print(concat("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /* 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ /* remove from option list ral any non-permitted options */
+ kill(y),
+ permitted_options: [y, xlabel, ylabel, legend, color, style, point_type, nticks, logx, logy, axes, box, plot_realpart],
+ if not(emptyp(lvs)) then permitted_options:append([first(lvs)], permitted_options),
+ ralforbid:sublist(ral, lambda([ex], not(member(first(ex), permitted_options)))),
+ if not(emptyp(ralforbid)) then
+ (print(concat("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /* Assemble files names and URLs */
+ tn:string(absolute_real_time()),
+ filename:concat("stackplot","-",tn,"-",string(rand(10^8))),
+ tfn:concat(TMP_IMAGE_DIR, filename, ".plt"),
+ afn:concat("'", IMAGE_DIR, filename, ".", PLOT_TERMINAL, "'"),
+ ufn:concat("<div class=\"stack_plot\"><img src='", URL_BASE, filename, ".", PLOT_TERMINAL, "' alt='", alttext, "' /></div>"),
+ if OPT_OUTPUT#"MathML" then
+ 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]])
+ ),
+ if not(member(axes, maplist(first, ral))) then block([lv],
+ preamble:"set zeroaxis
+set grid
+"
+ ),
+ /* Note, the axes option in Maxima doesn't seem to work.... */
+ preamble:concat(preamble, "set terminal ",PLOT_TERMINAL," ",PLOT_TERM_OPT,"
+set output ",afn),
+ set_plot_option([gnuplot_out_file, tfn]),
+ set_plot_option([gnuplot_preamble, preamble]),
+ /* Create and execute the actual plot commands */
+ pltargs:append([ex], ral),
+ plotfunmake:funmake(plot2d, pltargs),
+ ev(plotfunmake),
+ sysp:concat(GNUPLOT_CMD, " ", tfn),
+ sysr:concat(DEL_CMD, " ", tfn),
+ system(sysp),
+ system(sysr),
+ simp:old_simp,
+ return(ufn)
+)$
+
+/* ********************************** */
+/* Numerical operations */
+/* ********************************** */
+
+ATNumAbsolute(SA, SB) := ATNumerical(SA, SB, "ABSOLUTE")$
+ATNumRelative(SA, SB) := ATNumerical(SA, SB, "RELATIVE")$
+
+
+ATNumerical(SA, SB, numtype) := block([simp:true, RawMark, FeedBack, AnswerNote, ret, SAN, tol],
+ Validity:false, 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(SB), simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_TAns")),
+ SB:SB[1],
+ if not(listp(SB)) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_TA_not_list"))),
+ if not(is(length(SB)=2)) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_TA_wrong_length"))),
+ tol:SB[2],
+ 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"))),
+ SB:SB[1],
+
+ /* 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 lists? */
+ if setp(SB) then
+ if 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? */
+ /*print(ev(abs(float(SA-SB)), simp)),
+ print(ev(abs(tol)+STACK_NUM_TOL, simp)),*/
+ if numberp(SAN) then
+ if numberp(TA) then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_number"))
+ else
+ if numtype = "ABSOLUTE" then
+ return([false, numabsolutep(SA, SB, tol), "", ""])
+ else
+ return([false, 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;
+numrelativep(sa,ta,tol) := if ev(abs(float(sa-ta)), simp) < ev(abs(ta*tol)+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", StackDISP(SBl, "i"), StackDISP(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", StackDISP(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", StackDISP(SBl, "i"), StackDISP(SAl, "i"))]),
+
+ SA:sort(float(listify(SA))),
+ SB:sort(float(listify(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", StackDISP(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,SBL) := block([Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, 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("","ATNumSigFigs_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SBL, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_TAns"), ""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ /* Sort out options */
+ if listp(SBL) then (SB:SBL[1], ol:SBL[2]) else
+ (print("TEST_FAILED"), return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_no_option"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ 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 not(integerp(nsf) and integerp(asf)) then
+ (print("TEST_FAILED"),return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* SA should be only a number. */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ SA:SA[1],
+ if (not(floatnump(SA)) and not(integerp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* Puts Teacher's answer between 0 & 1 */
+ c0:-floor(log(abs(float(SB)))/log(10)+1),
+ c1:SA*10^(c0+floor(nsf)),
+ if is(float(c1-floor(c1))=0.0)=false then block(
+ Validity:true,
+ RawMark:false,
+ FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_WrongDigits"),
+ AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_WrongDigits")
+ ),
+ c2:abs(abs(SA*10^(c0+floor(asf)))-abs(SB*10^(c0+floor(asf)))),
+ if not(is(c2<0.5)) then block(
+ Validity:true,
+ RawMark:false,
+ FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_Inaccurate"),
+ AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_Inaccurate")
+ ),
+ if RawMark = true then AnswerNote:"",
+ ret: [Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+)$
+
+/* ********************************** */
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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", StackDISP(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, eg 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([keepfloat, RawMark, FeedBack, AnswerNote, ret],
+ Validity:true, RawMark:false, FeedBack:"", AnswerNote:"",
+ keepfloat:true,
+ /* 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 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 an equation? */
+ if equationp(SB) then
+ if equationp(SA)#true then
+ return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_equation"))
+ else
+ return(ATEquation(SA, SB)),
+ /* Did the student type in an equation, but the teacher did not? */
+ if equationp(SA) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ /* Are we dealing with an inequality? */
+ if inequalityp(SB) then
+ if inequalityp(SA)#true then
+ return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_inequality"))
+ else
+ return(ATInequality(SA, SB)),
+ /* Are we dealing with lists? */
+ if setp(SB) then
+ if setp(SA)=false then
+ return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_set"))
+ else
+ return(ATSet(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, k, 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", StackDISP(SBl, "i"), StackDISP(SAl, "i"))]),
+
+ /* Apply ATAlgEquivfun to each element pair */
+ ret:[true, true, "", ""],
+ AddFeedBack:false,
+ AnsNotes:[],
+ for k:1 thru SAl do block([retnew],
+ retnew:ATAlgEquivfun(SA[k], SB[k]),
+ ret[1]:ret[1] and retnew[1],
+ ret[2]:ret[2] and retnew[2],
+ if not(retnew[3]="") then
+ AnsNotes:cons(concat(string(k), ": ", StackTrimNote(retnew[3])), AnsNotes)
+ else if retnew[2]=false then
+ AnsNotes:cons(string(k), AnsNotes),
+ if retnew[2] = false then block(
+ /* ret[4]:concat(ret[4],retnew[4]), */
+ if not(listp(SA[k]) or matrixp(SK[k]) or setp(SK[k])) then block(
+ SAN[k]:texcolor("red", SA[k])
+ ),
+ AddFeedBack:true
+ )
+ ),
+ if AddFeedBack = true then block(
+ ret[3]:StackAddNote("", concat("(ATList_wrongentries ", simplode(reverse(AnsNotes), ", "), ")") ),
+ ret[4]:concat(StackAddFeedback("", "ATList_wrongentries", StackDISP(SAN, "d")), ret[4])
+ ),
+ return(ret)
+)$
+
+/* Equations */
+/* Note, this uses exand, 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, R1, R2],
+ keepfloat:false,
+ RawMark:false,
+
+ /* First try without expanding out the equations */
+ R1:ev(lhs(factor(SA))-rhs(factor(SA)), simp),
+ R2:ev(lhs(factor(SB))-rhs(factor(SB)), simp),
+ if (R1=0 and R2=0) then
+ return([true, true, "", ""]),
+ if numberp(float(abs(R1/R2))) then
+ return([true, true, "", ""]),
+ /* Next, expand out the equations */
+ SA1:stack_eqnprepare(SA),
+ SB1:stack_eqnprepare(SB),
+ if SA1#0 then
+ /* We need a slight hack to turn %i+1 into a number */
+ RawMark:block(
+ SB2:float(abs(ev(fullratsimp(SA1/SB1),simp))),
+ if numberp(SB2) then true else false
+ )
+ else
+ RawMark:if SB1=0 then true else false,
+ return([true, RawMark, "ATEquation_expanded", ""])
+ )$
+
+ATInequality(SA, SB) := block([RawMark, FeedBack, AnswerNote, SA1, SB1, samex],
+ RawMark:false, FeedBack:"", AnswerNote:"",
+ /* Write the inequalities in canonical form then compare. */
+ SA:ineqorder(SA),
+ SB:ineqorder(SB),
+ if SA = SB then RawMark:true,
+ /* Now try to give some basic feedback: potential for more work to recurse over complex expressions... */
+ if op(SA) = ">" and op(SB) =">=" then block(
+ AnswerNote:StackAddNote("", "ATInequality_strict"),
+ FeedBack:StackAddFeedback("", "ATInequality_strict")
+ ),
+ if op(SA) = ">=" and op(SB) =">" then block(
+ AnswerNote:StackAddNote("", "ATInequality_nonstrict"),
+ FeedBack:StackAddFeedback("", "ATInequality_nonstrict")
+ ),
+ if (">" = op(SA) or ">=" = op(SA)) and (">" = op(SB) or ">=" = 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]),
+ SA1:args(SA), SAd1:second(SA1),
+ SB1:args(SB), SBd1:second(SB1),
+ /* 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]),
+ FeedBack:StackAddFeedback("", "ATMatrix_wrongsz", StackDISP(SBr, "i"), StackDISP(SBc, "i"), StackDISP(SAr, "i"), StackDISP(SAc, "i")),
+ if (SAr#SBr) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), FeedBack]),
+ if (SAc#SBc) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ ret:[true, true, "", ""],
+ AddFeedBack:false,
+ for k:1 thru SAr do block([retnew],
+ retnew:ATAlgEquivfun(SA[k],SB[k]),
+ 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", StackDISP(SA, "d"))
+ ),
+ return(ret)
+ )$
+
+/* An answer test based on two sets for SA and SB. */
+ATSet(SA, SB) := block([RawMark, FeedBack, AnswerNote, str, SAl, SBl, ZM],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Get sizes of matrices */
+ SAl:cardinality(SA),
+ SBl:cardinality(SB),
+ FeedBack:StackAddFeedback("", "ATSet_wrongsz", StackDISP(SBl, "i"), StackDISP(SAl, "i")),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ SA:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", StackDISP(setdifference(SA, SB), "d")),
+ return([true, false, StackAddNote("","ATSet_wrongentries"), 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.
+ Note, this is identical to ATAlgEquiv with simp:false otherwise. */
+ATLowestTerms(SA, SB) := block([simp:false, ret, validity, mark, FeedBack, AnswerNote, SAA],
+ /* 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", StackDISP(badNos, "d"))
+ ),
+ return([validity, mark, AnswerNote, FeedBack])
+)$
+
+
+
+ATSubstEquiv(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("", "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],
+ ret:ATAlgEquivfun(SA, SB),
+ /* 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", StackDISP(p1, "d"))]
+ ),
+ /* Send back result */
+ return(ret)
+)$
+
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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", StackDISP(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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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 */
+ 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"),""]),
+
+ /* 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 not is(ev(setify(listofvars(S1)),simp)=ev(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],
+
+ /* 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 k:1 thru length(SA) do block([],
+ if ev(poly_grobner_member(stack_eqnprepare(stack_eval_assignments(SA[k])), GB, varlist),simp) then
+ ret:append(ret,[SA[ev(k,simp)]])
+ else
+ ret:append(ret,[texcolor("red", SA[ev(k,simp)])])),
+
+ return([true,false,StackAddNote("","ATSysEquiv_SA_system_overdetermined"),StackAddFeedback("","ATSysEquiv_SA_system_overdetermined", StackDISP(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"),""]),
+
+ if SA=SB then
+ (RawMark:true, AnswerNote:"ATCASEqual_true")
+ else
+ 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 numberss** */
+
+/* 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",StackDISP(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(p,v) := block([negdistrib,PARTSWITCH,fb,i,irred,res],
+ negdistrib:false,
+ partswitch:true,
+ fb:"",
+ res:true,
+ if atom(p) then return([true,""]) else
+ if op(p)="+" then return(irred_Q(p,v)) else
+ if op(p)="^" then return(irred_Q(part(p,1),v)),
+ /* So we have a *, or a / */
+ for i:1 step 1 while ev(part(p,i),simp)#end do
+ ( /* We just need to go one level down! */
+ irred:block([q], q:part(p,ev(i,simp)),
+ if atom(q) then return([true,""]) else
+ if op(q)="+" then return(irred_Q(q,v)) else
+ if op(q)="^" then return(irred_Q(part(q,1),v)) else return([false,""])
+ ),
+ res:res and irred[1],
+ if irred[1]=false then
+ (fb:StackAddFeedback(fb,"FacForm_UnPick_morework",StackDISP(part(p,ev(i,simp)),"i")),
+ fb:concat(fb,irred[2])
+ )
+ ),
+ return([res,fb])
+ )$
+
+
+/* Factored form of a polynomial? */
+/* Assumes all coefficients are integers */
+
+ATFacForm(SA,SBL) := block([negdistrib,RawMark,FeedBack,AnswerNote,ret,str,SB,v,SAA,SBB,coefl,facdum],
+ negdistrib:false,
+ /* include facdum:'facdum, as in partfrac? */
+ 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(SBL, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false, false, StackAddNote("", "ATFacForm_STACKERROR_TAns"), ""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ if listp(SBL) then (SB:SBL[1], v:SBL[2]) else
+ return([false, false, StackAddNote("", "ATFacForm_STACKERROR_LIST"), StackAddFeedback("", "TEST_FAILED")]),
+
+ /* 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(v)#true then (SA:subst(facdum, v, SA),SB:subst(facdum, v, SB), v:facdum),
+ ret: FacFormfun(SA,SB,v),
+ return(ret)
+ )$
+
+FacFormfun(SA,SB,v) := 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), v)) = [] then block(
+ val: false,
+ rawmk: false,
+ ansnote: StackAddNote("", "ATFacForm_error_degreeSA"),
+ fb: StackAddFeedback("", "ATFacForm_error_degreeSA")
+ ),
+ aequiv:algebraic_equivalence(SA,SB),
+ /* 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,v) ),
+ 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"),
+ cont:false /* Unsure what this is for - not used anywhere, or returned, in original code! */
+ )
+ )
+ ),
+ 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: StackReturn */
+/* 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,SBL) := block([negdistrib,Validity,rawmk,fb,ansnote,ret,SB,v,facdum,wrt,tExpr,sExpr,SAA,SBB],
+ negdistrib:false,
+ facdum:'facdum,
+ Validity:true, rawmk:true, fb:StackAddFeedback("",""), 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"), ""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ if listp(SBL) then (tExpr:SBL[1], wrt:SBL[2]) else
+ return([false,false,StackAddNote("","ATFacForm_STACKERROR_LIST"),StackAddFeedback("","TEST_FAILED")]),
+
+ /* SA should be only an expression. */
+ if expressionp(SA)=false then
+ return([false, false, StackAddNote("", "ATPartFrac_SA_not_expression"), StackAddFeedback("", "ATAlgEquiv_SA_not_expression")]),
+
+ /* tExpr should be only an expression. */
+ if expressionp(tExpr)=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(v)#true then (SA:subst(facdum,wrt,SA),tExpr:subst(facdum,wrt,tExpr),wrt:facdum),
+ ret: PartFracfun(SA,tExpr,wrt),
+ 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 = DIV_OP 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", StackDISP(denom(factor(sExpr)),"i"), StackDISP(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", StackDISP(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****************************** */
+/* requires: Student Answer */
+/* List: [Teachers Answer, variable with which partial */
+/* fraction occurs, whether Formative Feedback is required */
+/* returns: StackReturn */
+/* Cases: */
+/* Returns True iff algebraic equivalence with TList[1] */
+/* and Division is the Top Operator. */
+/* False if Division not the top operator */
+/* False if different Variables are used */
+/* True(0) otherwise */
+/* ******************************************************************** */
+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")),
+
+ /* Check for single fraction */
+ fbn:"",
+ if op(SA) = DIV_OP then block(
+ if (freeof(DIV_OP,num(SA)) and freeof(DIV_OP,denom(SA))) then block(
+ rawmk:true,
+ ansnote:"ATSingleFrac_true")
+ else 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])
+)$
+
+
+/*****************************************************************/
+/* Useful function for Partial Fractions */
+/*****************************************************************/
+
+divthru(q):=
+ if (not atom(q) and part(q,0)=DIV_OP)
+ then
+ block([num,den,div,quo,rem],
+ num:part(q,1),
+ den:part(q,2),
+ div:divide(num,den) ,
+ quo:div[1],
+ rem:div[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([k,ret,sAargs,sAset,tAargs,tAset,dTA,dTB],
+ tAargs:args(TA),
+ tAset:set(),
+ /* Create a set of +-1*denoms in the teacher's expression */
+ for k:1 thru length(tAargs) do block(
+ dTA : ev(expand(denom(tAargs[k])),simp),
+ dTB : ev(expand(-1*denom(tAargs[k])),simp),
+ tAset : union(set(dTA,dTB),tAset)
+ ),
+ /* Create a set of +-1*denoms in the student's expression */
+ sAargs:args(SA),
+ sAset:set(),
+ for k:1 thru length(sAargs) do block(
+ dTA : ev(expand(denom(sAargs[k])),simp),
+ dTB : ev(expand(-1*denom(sAargs[k])),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,SBL) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,SB,SAA,SBB,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"), ""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ if listp(SBL) then (SB:SBL[1], wrt:SBL[2]) else
+ return([false,false,StackAddNote("", "ATCompSquare_STACKERROR_LIST"), ""]),
+
+ /* 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", StackDISP(SBL[2], "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 */
+ 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=DIV_OP 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])="^" 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,sbl) :=
+ block([oldsimp, keepfloat, Validity, RawMark, FeedBack, AnswerNote, var, sb, ret, cont],
+ oldsimp:simp, simp:false, Validity:true, RawMark:false, FeedBack:"", AnswerNote:"",
+ keepfloat:true,
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATInt_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sbl, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false, false, StackAddNote("", "ATInt_STACKERROR_TAns"), ""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ if listp(sbl) then
+ (var:sbl[2], sb:sbl[1], cont:true)
+ else
+ (cont:false, FeedBack:StackAddFeedback("", "ATInt_STACKERROR_LIST"), AnswerNote:StackAddNote("", "ATInt_STACKERROR_LIST")),
+ ret:[true,RawMark,AnswerNote,FeedBack], /* Once this works remove these variables and define ret in the loops */
+
+ /* 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,
+ if cont then
+ ret:Intfun(sa, sb, var)
+ ),
+ simp:oldsimp,
+ return(ret)
+ )$
+
+/* 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)))$
+
+Intfun(SA, SB, v) := block([val,rawmk,ansnote,fb,ret,ex,SAd,SBd,saa,dd,dc,lSAv,lSBv,mSAv,mSBv,SAConsistentLogs,SAUsedLogAbs,SBUsedLogAbs],
+ val:true, rawmk:false, fb:"", ansnote:"", debug:false,
+ 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,v),
+ SBUsedLogAbs:ATInt_logabs_p(SB,v),
+ if debug then print([SA,SB]),
+ if debug then print([SAUsedLogAbs,SBUsedLogAbs]),
+ /* This expands out logarithms for constants, e.g. ln(k*|x|) */
+ SB:ev(SB, logexpand:super, simp),
+ if debug then print([SA,SB]),
+ /* This strips off any trailing constant of integration from the teacher's answer */
+ SB:strip_int_const(SB, v),
+ /* This strips off any trailing constant of integration from the student's answer */
+ SAa:strip_int_const(ev(SA, logexpand:super, simp), v),
+ /* 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,v),
+ 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,v),simp),
+ SBd:ev(diff(SB,v),simp),
+ /* 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", StackDISP(SBd, "d"), StackDISP(v, "i"), StackDISP(SAd, "d"))])),
+ ex:ex[1],
+ ex:ev(trigsimp(ex), simp),
+ ex:ev(trigreduce(ex), simp),
+ dd:ev(float(ex), simp),
+ dc:numberp(dd) and dd#0.0,
+ if debug then print([SAa,SBd]),
+ if debug then print(ex),
+ if ev(algebraic_equivalence(SAd,SBd), simp) then
+ if ex=0 then
+ (rawmk:false, fb:StackAddFeedback("", "ATInt_const"), ansnote:StackAddNote("", "ATInt_const"))
+ else if dc then
+ (rawmk:false, fb:StackAddFeedback("", "ATInt_const_int"), ansnote:StackAddNote("", "ATInt_const_int"))
+ else if freeof(log, SA) and not(ATIntWeirdConstp(ex)) then
+ (rawmk:true, ansnote:StackAddNote("", "ATInt_true"))
+ else if freeof(log, SA) and ATIntWeirdConstp(ex) then
+ (rawmk:false, fb:StackAddFeedback("", "ATInt_weirdconst"), ansnote:StackAddNote("", "ATInt_weirdconst"))
+ /* 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(v,ex) and not(ATIntWeirdConstp(ex)) 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, v), 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", StackDISP(SBd, "d"), StackDISP(v, "i"), StackDISP(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(v, lSAv),
+ mSBv:member(v, 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") ) /* v 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):=block([l],
+ 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, v):=block(
+ if ex=v then return(false), /* v on its own is not inside abs() */
+ if atom(ex) then return(true),
+ if freeof(v,ex) then return(true),
+ if safe_op(ex) = "abs" then return(true),
+ apply("and", maplist(lambda([ex2], ATInt_var_in_abs_p(ex2, v)), args(ex)))
+)$
+
+/* Check if all occurances of the variable v, which are inside a log function, are protected by abs() */
+ATInt_logabs_p(ex, v):=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, v)), args(ex)))),
+ apply("and", maplist(lambda([ex2], ATInt_logabs_p(ex2, v)), 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,v):=block(
+ if atom(ex) then return(0),
+ if safe_op(ex) = "log" and ATInt_var_in_abs_p(ex, v) then return(STACKLOGABS),
+ if safe_op(ex) = "log" and member(v, listofvars(args(ex))) then return(STACKLOG),
+ return(apply("+",maplist(lambda([ex1],ATInt_consistent_logabs_p_helper(ex1,v)),args(ex))))
+);
+
+ATInt_consistent_logabs_p(ex,v):=block([helper],
+ helper:ev(ATInt_consistent_logabs_p_helper(ex,v),simp),
+ helper:listofvars(helper),
+ if member(STACKLOG, helper) and member(STACKLOGABS, helper) then false else true
+);
+
+/********************************************************************/
+/* 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,sbl) :=
+ block([old_simp, keepfloat, RawMark, FeedBack, AnswerNote, ret, str, da, db, dd, dc, sb, var, cont, SAA, SBB],
+ old_simp:simp, simp:true, 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(sbl, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then return([false,false,StackAddNote("","ATDiff_STACKERROR_TAns"),""]),
+
+ /* SBL is a list: the teacher's answer, the variable, and whether formative feedback is to be provided. */
+ if listp(sbl) then
+ (var:sbl[2], sb:sbl[1], cont:true)
+ else
+ (cont:false, FeedBack:StackAddFeedback("","ATDiff_STACKERROR_LIST"), AnswerNote:StackAddNote("","ATDiff_STACKERROR_LIST")),
+ ret:[cont, RawMark, AnswerNote, FeedBack], /* In case sbl not list */
+
+ /* 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,
+ if cont then
+ ret:Difffun(sa,sb,var)
+ ),
+ 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 algebraic_equivalence(diff(SA,v),int(SB,v)) 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)
+ )$
+
+/* ****************************************************** */
+/* */
+/* 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("")
+)$
+
+/* Slight hack to compile these functions and hence suppress warnings. */
+load(linearalgebra);
+
+/* Stack expects some output */
+stackmaximaversion:2014083000$
+print("[ STACK-Maxima started, library version 2014083000 ]")$
diff --git a/stack/2014083000/maxima/stackreporting.mac b/stack/2014083000/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93
--- /dev/null
+++ b/stack/2014083000/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(
+ print("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/2014083000/maxima/stacktex.lisp b/stack/2014083000/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9c89c8593fc73a280b8f62529bddbb9630b78dc1
--- /dev/null
+++ b/stack/2014083000/maxima/stacktex.lisp
@@ -0,0 +1,181 @@
+;; 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.
+
+;; 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-unaryminus tex)
+;;(defprop mminus tex-prefix tex)
+(defprop mminus ("-") texsym)
+
+(defun tex-prefix-unaryminus (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)
+
+
+(defun tex-texdecorate (x l r)
+ (let
+ ((front (append '("{")
+ (list (stripdollar (cadr x)))
+ '("")))
+ (back (append '("{")
+ (tex (caddr x) nil nil 'mparen 'mparen)
+ '("}}"))))
+ (append l front back r)))
+
+(defprop $texdecorate tex-texdecorate 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". Hmmm.
+ ; 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 "") "")
+ ((eql (elt x 0) #\\) x)
+ (t (concatenate 'string "\\mbox{" x "}"))))
+
+
+;; Sort out display on inequalities
+;; Chris Sangwin, 21/9/2010
+
+(defprop mlessp (" < ") texsym)
+(defprop mgreaterp (" > ") texsym)
+
+;; Change the display of derivatives, at the request of the OU
+;; Chris Sangwin, 18/3/2013
+
+(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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((blankmult) ((mexpt) ,dsym ((mplus) ,@ords)) ,arg)) ; d^n numerator
+ (denom (cons '(blankmult)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mquotient) ,(simplifya numer nil) ,(simplifya denom nil))
+ ))
+
+
+(defprop blankmult tex-infix tex)
+(defprop blankmult ("\\, ") texsym)
+
diff --git a/stack/2014083000/maxima/unittests_load.mac b/stack/2014083000/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..fe125baa77bae74a9e36679d93b20371039f3c64
--- /dev/null
+++ b/stack/2014083000/maxima/unittests_load.mac
@@ -0,0 +1,49 @@
+;; Author Chris Sangwin
+;; University of Birmingham
+;; Copyright (C) 2013 Chris Sangwin
+
+;; 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.
+
+
+/* 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 */
+
+kill(all);
+/*load("C:/xampp/htdocs/stack-dev/logfiles/maximalocal.mac")$*/
+LOADDIR:"C:/xampp/data/moodledata/stack/maximalocal.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);
+
+simp:false$
+SFF:batch("rtest_assessment_simpfalse.mac", test);
+SFB:batch("rtest_assessment_simpboth.mac", test);
+
+print("************ simp is true");
+print(STT);
+print(STB);
+
+print("************ simp is false.");
+print(SFF);
+print(SFB);
+
+
diff --git a/stack/2017121800/maxima/arccos.lisp b/stack/2017121800/maxima/arccos.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..963ff6b45f83923546f7163cc973266c91102e7e
--- /dev/null
+++ b/stack/2017121800/maxima/arccos.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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/2017121800/maxima/assessment.mac b/stack/2017121800/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..7158924091ec37f451b4759e7c5bf2b15119d930
--- /dev/null
+++ b/stack/2017121800/maxima/assessment.mac
@@ -0,0 +1,1886 @@
+/* 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/>. */
+
+
+/****************************************************************/
+/* An assessment package for Maxima */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.7 September 2015 */
+/* */
+/****************************************************************/
+
+MAXIMA_VERSION:map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp))$
+MAXIMA_VERSION_NUM:float(MAXIMA_VERSION[2]+(if is(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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],
+ 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
+);
+
+/* 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)$
+
+/* ********************************** */
+/* 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)
+)$
+
+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) 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);
+
+/* Add in support for logarithms to an arbirary base. */
+lg([ex]) := block(
+ if length(ex) = 1 then return(logbase(first(ex), 10)),
+ if length(ex) = 2 then return(logbase(first(ex), second(ex))),
+ error("STACK function 'lg' must have one or two arguments only.")
+)$
+
+logbasetex(ex) := block([n, b],
+ [n, b]:args(ex),
+ oldsimp:simp,
+ return(concat("\\log_{", stack_disp_strip_dollars(tex(b, false)), "}\\left(", stack_disp_strip_dollars(tex(n, false)), "\\right)"))
+)$
+texput(logbase, logbasetex);
+
+/* Use of radcan to give canonical form. */
+logbasesimp(n,b) := radcan(log(n)/log(b));
+
+/* 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), logbase=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)
+)$
+
+/* 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)
+)$
+
+/* 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)), logbase=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 not(integerp(n)) then error("significantfigures(x,n) requires an integer as a second 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), logbase=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([a]) := block([simp:false, x, ex, ex2, ex3, exn],
+ 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), logbase=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),
+ return(ex3)
+ ),
+ 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.
+*/
+
+
+/* ********************************** */
+/* 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/9/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.
+*/
+algebraic_equivalence(SA, SB) :=
+ block([keepfloat, trigexpand, logexpand, ex, vi],
+ /* Reject obviously different expressions. These can be very time consuming in the tests below. */
+ /* The code below is actually making the situation worse: needs reconsidering. */
+ if numerical_not_alg_equiv(SA, SB) then return(false),
+ trigexpand:true,
+ 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 scientific units and displaydp from expressions. */
+ SA:ev(SA, stackunits="*"),
+ SB:ev(SB, stackunits="*"),
+ 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(logbase, SA)) then
+ SA:ev(SA, logbase=logbasesimp),
+ if not(freeof(logbase, SB)) then
+ SB:ev(SB, logbase=logbasesimp),
+ /* Try not to expand out: pure numbers. */
+ ex:errcatch(ev(SA-SB, simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: factoring the difference of two expressions threw an error."), return(false)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ ex:errcatch(ratsimp(ex)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 */
+ 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],
+ /* 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 is(pval = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ if abs(first(pval)) > 1/10000 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)),
+ sz:errcatch(ev(abs(float(first(p1)-first(p2))), 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);
+
+verb_arith(ex) := block(
+ 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(
+ 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))))),
+ apply(op(ex), maplist(flatten_recurse_nouns, args(ex)))
+)$
+
+/* 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, ex1n, ex2n, ret],
+ oldsimp:simp,
+ simp:false,
+ ex1n:noun_arith(ex1),
+ ex2n:noun_arith(ex2),
+ simp:true,
+ ex1n:ev(flatten_recurse_nouns(ex1n), simp),
+ ex2n:ev(flatten_recurse_nouns(ex2n), simp),
+ if ex1n=ex2n then ret:true else ret:false,
+ simp:oldsimp,
+ ret
+)$
+
+/* An answer test in the context of commutative+associative addition and multiplication. */
+ATEqualComAss(sa, sb) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB],
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]),
+
+ /* We need 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)$
+
+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) = "and" then return(true),
+ if safe_op(ex) = "or" then return(true),
+ if safe_op(ex) = "not" then return(true),
+ if op_usedp(ex, "+-") 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", "and", "or", "%and", "%or", "not", "%not", "+-", "<", ">", "<=", ">=", "=", "[", "{"],
+ 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:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", ex),
+ ex:subst("%and", "and", ex),
+ ex:subst("%or", "or", ex),
+ ex:de_morgan(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)
+)$
+
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ return(rex)
+)$
+
+/****************************************************************/
+/* Define noun versions of other functions */
+/****************************************************************/
+
+nounint([ex]):=apply(nounify(integrate), ex)$
+noundiff([ex]):=apply(nounify(diff), ex)$
+
+/* ********************************** */
+/* Add in a +- operator */
+/* ********************************** */
+
+/* We have to define +- to be both a prefix and an nary operator in this order. */
+prefix("+-");
+nary("+-", 100);
+
+displaypmtex(ex):=block([al, a1, a2],
+ al:args(ex),
+ if is(length(al)=1) then
+ return(sconcat(" \\pm ", tex1(first(al)))),
+ a1:tex1(first(al)),
+ a2:tex1(second(al)),
+ sconcat("{", a1, " \\pm ", a2, "}")
+ );
+texput("+-", 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, "+-")=1), simp) then return(opsubst("+", "+-", ex) nounor opsubst("-", "+-", 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 ev(argfac=factor(argfac), simp) then
+ return(true),
+ if mapatom(argfac) then
+ return(false),
+ /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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 (
+ print("comp_square: var should be an atom but not a number. "),
+ return(ex)
+ ),
+ ex:ratsimp(expand(ex)),
+ if not(polynomialp(ex, [var])) then (
+ print("comp_square: ex should be a polynomial in var. "),
+ return(ex)
+ ),
+ if hipow(ex, var)#2 then (
+ print("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 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 */
+/****************************/
+
+/*
+ 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
+)$
+
+addrow(m,i,j,k) := block([n,p],
+ require_matrix(m, "first", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_integer(j, "third", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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 : addrow (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(EQUIVCHARREAL, "\\color{green}{\\Leftrightarrow}\\, \\color{blue}{(\\mathbb{R})}");
+texput(CHECKMARK, "\\color{green}{\\checkmark}");
+texput(IMPLIESCHAR, "\\color{red}{\\Rightarrow}");
+texput(IMPLIEDCHAR, "\\color{red}{\\Leftarrow}");
+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, " ");
+
+
+/* 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 intert prefix equality symbol. */
+stackeqtex(ex):=block([ss, n, dp],
+ sconcat("=", tex1(first(args(ex))))
+);
+texput(stackeq, stackeqtex);
+
+/* 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 (print("stack_disp_arg expects to receive a list."), return(false)),
+ 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)),
+ exnatdomain:makelist(EMPTYCHAR, 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),
+ 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,"+-")=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, logbase=logbasesimp),
+ exmod[ev(id, simp)]:SA,
+
+ if ev(is(equal(length(listofvars(SA)),1)), simp) then
+ exmodsolve[ev(id, simp)]:ev(single_variable_solver_real(SA), simp)
+ else
+ exmodsolve[ev(id, simp)]:ev(logical_normal(SA), simp),
+
+ /* 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)),
+ if (debug) then print(SA),
+ if (debug) then print(SB),
+ if (debug) then print(SAP),
+ if (debug) then print(SBP),
+ if (debug) then print(SAS),
+ if (debug) then print(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 (
+ 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],
+ 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, 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(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 cause 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))
+ ),
+
+ /* 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))
+ )
+ )
+ ),
+
+ /* Can we work out what has gone wrong? */
+ if (debug) then print("** Checking for common mistakes **"),
+ if (debug) then print(SA),
+ if (debug) then print(SB),
+ 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,
+
+ 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(
+ malrulecont:false,
+ eqoutcome[ev(id, simp)]:false,
+ eqoutsymb[ev(id, simp)]:IMPLIEDCHAR,
+ tempnote:sconcat(tempnote, " | SquaredSecond | ", 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. */
+ 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)
+ ),
+ res:matrix(eqoutcome, eqoutsymb, ex, exnatdomain, eqoutnote),
+ return(transpose(res))
+);
+
+/* This modifies stack_eval_arg to create something which can be displayed. */
+stack_eval_equiv_arg(ex, showlogic, 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
+ res:unknown
+ 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 (
+ print("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, equivdebug, debuglist) := block([A],
+ A:stack_eval_equiv_arg(ex, showlogic, equivdebug, debuglist),
+ return(second(A))
+)$
+
+/* This modifies stack_eval_arg to create something which can be displayed. */
+stack_disp_arg(ex, showlogic) := block([A],
+ A:stack_eval_equiv_arg(ex, showlogic, 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),
+ return(first(ret))
+)$
+
+/* An answer test based on equivalence reasoning. */
+ATEquiv(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack],
+
+ /* 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,
+
+ /* 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, 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],
+
+ /* 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,
+
+ /* 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, false, false),
+ AnswerNote:third(A),
+ FeedBack:stack_disp(second(A), "d"),
+
+ ret:[true, first(A), AnswerNote, FeedBack],
+ return(ret)
+)$
diff --git a/stack/2017121800/maxima/assessment.texi b/stack/2017121800/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/complexi.lisp b/stack/2017121800/maxima/complexi.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8be0972956d17463313be86ea1bd76f1b9552cbb
--- /dev/null
+++ b/stack/2017121800/maxima/complexi.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{i}" texword)
+
+(defprop $%i "<mi>i</mi> " mathmlword)
diff --git a/stack/2017121800/maxima/complexj.lisp b/stack/2017121800/maxima/complexj.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1fdfd5b91a8993b84fc72fd9f39114151c8dd4ce
--- /dev/null
+++ b/stack/2017121800/maxima/complexj.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{j}" texword)
+
+(defprop $%i "<mi>j</mi> " mathmlword)
diff --git a/stack/2017121800/maxima/cos-1.lisp b/stack/2017121800/maxima/cos-1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7cdb2e2d0c69d196c7ae93ea9c9f2740ece76b59
--- /dev/null
+++ b/stack/2017121800/maxima/cos-1.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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 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/2017121800/maxima/elementary.mac b/stack/2017121800/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..77cb7ddc99b1fb2410361c1cefb654b41cc414ed
--- /dev/null
+++ b/stack/2017121800/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 print("ERROR: 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/2017121800/maxima/expandfeedback.mac b/stack/2017121800/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/experimental.mac b/stack/2017121800/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..98afe06e41c2d99210e1ca9301fcd43e1b447811
--- /dev/null
+++ b/stack/2017121800/maxima/experimental.mac
@@ -0,0 +1,175 @@
+/* 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))));
+
+/****************************************************************/
+/* Inequality functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.2 July 2013 */
+/* */
+/****************************************************************/
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* 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 (print("STACK exception: node_no expects its first argument to be a list."), return(false)),
+ if not(integerp(num)) then (print("STACK exception: node_no expects its second argument to be an integer."), return(false)),
+ if is(length(prt)<num) then (print("STACK exception: node_no expects its second argument to less than the length of the first."), return(false)),
+ /* 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 (print("STACK exception: traverse_prt expects its argument to be a list."), return(false)),
+ if not(alllistp(equationp,inputs)) then (print("STACK exception: traverse_prt expects its argument to be a list of equations."), return(false)),
+ /* 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, <chris@sangwin.com> */
+/* 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/2017121800/maxima/inequalities.mac b/stack/2017121800/maxima/inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1a2af9cf84bf637bf62d129e3f17ca9a5d09a19d
--- /dev/null
+++ b/stack/2017121800/maxima/inequalities.mac
@@ -0,0 +1,304 @@
+/* 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 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:expand(ex),
+ /* 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 print("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],
+ 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/2017121800/maxima/intervals.mac b/stack/2017121800/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..0dc6c5a7f92aa4cedde0a85a49eb5febc651780f
--- /dev/null
+++ b/stack/2017121800/maxima/intervals.mac
@@ -0,0 +1,1030 @@
+/* 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 intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.2 June 2017 */
+/* */
+/********************************************************************/
+
+/* 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
+ );
+*/
+
+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(Complement(b), simp),
+ if 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)],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(false),
+ 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 setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(intervalp, args(ex))),
+ 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=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 atom(ex) then return(false),
+ if setp(ex) and ex={} then return(true),
+ if save_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)
+)$
+
+SimpleUnion(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 setp(A) then
+ (
+ if 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 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 setp(A) or atom(B) or 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:SimpleUnion( 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)
+ )
+ )
+ )
+ )
+ ),
+ if safe_op(Ans)="[" then Ans:apply(%union, Ans),
+ Ans
+ );
+
+
+/* Finds the intersection of two "simple" sets: */
+SimpleIntersect(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 Ans:{} elseif
+ atom(B) then Ans:{} elseif
+ setp(A) then
+ (
+ if setp(B) then
+ (
+ return(intersect(A,B))
+ )
+ else
+ (
+ 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:{}
+ )
+ )
+ elseif setp(B) then
+ (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do
+ (if inintervalp(Aset[i],A) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans:setAns ) else Ans:{}
+ ),
+ if ( not atom(A) and not atom(B) ) then
+ (
+ Args1:args(A),
+ Args2:args(B),
+
+ if (not atom(A) and not(op(A)=set) and not atom(B) and not(op(B)=set) ) 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:{},
+ 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
+ );
+
+SimpDisjointp(A,B) := if SimpleIntersect(A,B)={} then true else false;
+
+/* Given a *list* of disjoint intervals, returns the same intervals but in ascending order: */
+SortUnion(X) :=
+ block ( [A:X, Ans:[], x, n, i],
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ if ( first( A[i] ) < first( x ) ) then x:A[i],
+ i:i+1
+ ),
+ Ans:append( Ans, [x] ),
+ A:delete( x, A, 1 ),
+ n:n-1
+ ),
+ Ans
+ );
+
+/* Given a union of disjoint intervals, checks whether any intervals are connected, and if so, joins them up and returns the ammended union: */
+ConnectIntervals(X):=
+ block ( [Ans, n, x, y, i:1],
+
+ if not(op(X)=%union) then error("ConnectIntervals requires a %union of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ if last( Ans[i] ) >= first( Ans[i+1] ) then
+ (
+ x:SimpleUnion( Ans[i], Ans[i+1] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[i+1], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ Ans:SortUnion(Ans),
+ n:n-1,
+ i:i-1
+ )
+ ),
+ 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: */
+TidyUnion(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),
+
+ if (not (op(X)=%union or op(X)="[") ) then Ans:X
+ else
+ (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<n+1 do
+ (
+ if ( setp(A[i]) ) then
+ (
+ setpart:union( setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ )
+ else if ( trivialintervalp(A[i]) ) then
+ (
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ ),
+ i:i+1
+ ),
+ A:SortUnion(A),
+ if length(A)=1 then
+ Ans:apply(%union, A)
+ else
+ Ans:ConnectIntervals(apply(%union, A)),
+ if length(setpart)>0 then Ans:append( args(Ans), [setpart] )
+ ),
+ Ans
+ )$
+
+/* Finds the union of any two sets: */
+Union(X, Y) :=
+ block ( [A, B, Ans:[], Joined:[], sets:{}, add, temp, x, y, m, n, k, i:1, j:1, f:1],
+ if atom(X) then Ans:Y
+ elseif atom(Y) then Ans:X
+ else
+ (
+
+ A:X,
+ if op(X)=%union then A:args(X),
+ B:Y,
+ if op(Y)=%union then B:args(Y),
+
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleUnion(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:Union(A,B) )
+ else
+ (
+ while i<(m+1)do
+ (
+ if op( A[i] ) = set then
+ (
+ sets:SimpleUnion( sets , A[i] ),
+ A:delete( A[i] , A , 1 ),
+ i:i-1,
+ m:m-1
+ ),
+ i:i+1
+ ),
+ i:1,
+ while j<(n+1)do
+ (
+ if op( B[j] ) = set then
+ (
+ sets:SimpleUnion( sets , B[j] ),
+ B:delete( B[j] , B , 1 ),
+ j:j-1,
+ n:n-1
+ ),
+ j:j+1
+ ),
+ j:1,
+ temp:Ans,
+
+ Joined:append(A,B),
+ Joined:JoinedUnion(Joined),
+ temp:append(temp,Joined),
+
+ if length(sets)>0 then
+ (
+ sets:listify(sets),
+ m:length(temp),
+ n:length(sets),
+ while j<(n+1) do
+ (
+ while i<(m+1) do
+ (
+ x:first( temp[i] ),
+ y:last( temp[i] ),
+ if inintervalp( sets[j], temp[i] ) then
+ (
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ )
+ elseif ( sets[j]=x or sets[j]=y ) then
+ (
+ temp[i]:Union( temp[i], { sets[j] } ) ,
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ ),
+ i:i+1
+ ),
+ i:1,
+ j:j+1
+ ),
+ j:1,
+ if length(sets)>0 then
+ (
+ sets:setify(sets),
+ temp:cons(sets,temp)
+ )
+ ),
+ if length(temp)=1 then temp:temp[1],
+ Ans:temp
+ )
+ ),
+ Ans:TidyUnion(Ans)
+ ),
+
+ Ans
+ );
+
+/* When given a union of intervals, this function simplifies the union by joining up any connected intervals: */
+JoinedUnion(X) :=
+ block ( [A, nextA:[], disjoint:[], temp, Ans:[], n, i, j, alldisjoint:false, Joined:[] ],
+
+ A:X,
+ if op(A)=%union then A:args(A),
+ while alldisjoint = false do
+ (
+ alldisjoint:true,
+ n:length(A),
+ disjoint:[],
+ i:1,
+ while i<n+1 do
+ (
+ disjoint: append(disjoint, [true] ),
+ i:i+1
+ ),
+ i:1,
+ while i<n do
+ (
+ j:i+1,
+ while j<n+1 do
+ (
+ if ( SimpDisjointp( A[i], A[j] ) ) then
+ (
+ if disjoint[j] = true then
+ (
+ nextA:delete( A[j], nextA, 1),
+ nextA:append(nextA, [ A[j] ] )
+ )
+ )
+ else (
+ nextA:delete( A[i], nextA, 1),
+ nextA:delete( A[j], nextA, 1),
+ temp:SimpleUnion( A[i], A[j] ),
+ if ( not op(temp) = "[" ) then temp:[temp],
+ nextA:append(nextA, temp ),
+ disjoint[i]:false,
+ disjoint[j]:false,
+ alldisjoint:false
+ ),
+ j:j+1
+ ),
+ if disjoint[i] = true then
+ (
+ nextA:delete( A[i], nextA, 1 ),
+ nextA:append(nextA, [ A[i] ] )
+ ),
+ i:i+1
+ ),
+ if alldisjoint = false then A:nextA,
+ nextA:[]
+ ),
+ Ans:A,
+ Ans
+ );
+
+Intersection(X,Y) :=
+ block ([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if is(A=all) then return(B)
+ elseif is(B=all) then return(A)
+ elseif atom(A) then Ans:{}
+ elseif atom(B) then Ans:{}
+ else
+ (
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleIntersect(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:SimpleIntersect(A,B) )
+ else
+ (
+ while i<m+1 do
+ (
+ while j<n+1 do
+ (
+ temp:SimpleIntersect( A[i], B[j] ),
+ if not atom(temp) then
+ (
+ Ans:append( Ans, [temp] )
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ )
+ ),
+ if (not atom(Ans)) and op(Ans) = "[" then
+ (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ )
+ ),
+ Ans:TidyUnion(Ans),
+ Ans
+ );
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+ListIntersect(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:Intersection(Ans,A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+OrderPoints(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:TidyUnion(A),
+ if op( last(A) ) = set 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
+ );
+
+
+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( Ans:oo(-inf,inf) ),
+ if not (op(A) = "[" or op(A)=%union) then
+ (
+ if op(A)=set then Ans:SetComplement(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:OrderPoints(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(ListIntersect(maplist(lambda([ex2], TidyUnion(Complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ else if listp(Ans) then
+ Ans:apply(%union, Ans)
+ ),
+
+ Ans
+ );
+
+SetComplement(X):=
+ block ( [A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("SetComplement 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, simp],
+ 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),
+
+ simp:false,
+
+ 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("%and", "and", ex),
+ ex:subst("%or", "or", ex),
+
+ if assume_pos then block
+ (
+ ex:ex %and (v>=0)
+ ),
+ ex:de_morgan(ex),
+
+ ex:block([assume_pos:false], single_variable_solver_real_rec(ex, v)),
+
+ if ((safe_op(ex)="[" or safe_op(ex)="%union") and 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), realsetp), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realsetp(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, realsetp), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realsetp(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([TidyUnion(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([ListIntersect(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: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 not(is(length(v)=1)) then return(unknown),
+ /* We only work over real expressions. */
+ if not(is(freeof(%i, 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)="sum" then
+ return(unknown),
+ /* The variables inside this are local. */
+ if safe_op(ex)="int" then
+ return(unknown),
+ 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)="logbase" 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(realsetp(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:ListIntersect(ex2),
+ ex2
+)$
diff --git a/stack/2017121800/maxima/mathml.lisp b/stack/2017121800/maxima/mathml.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7671dad91e31b7c9b9caf64c27e3891e2d73e4c0
--- /dev/null
+++ b/stack/2017121800/maxima/mathml.lisp
@@ -0,0 +1,762 @@
+(in-package "MAXIMA")
+;; MathML-printing
+;; Created by David Drysdale (DMD), December 2002/January 2003
+;;
+;; closely based on the original TeX conversion code in mactex.lisp,
+;; for which the following credits apply:
+;; (c) copyright 1987, Richard J. Fateman
+;; small corrections and additions: Andrey Grozin, 2001
+;; additional additions: Judah Milgram (JM), September 2001
+;; additional corrections: Barton Willis (BLW), October 2001
+
+;; Usage: mathml(d8,"/tmp/foo.xml"); mathml(d10,"/tmp/foo.xml"); ..
+;; to append lines d8 and d10 to the mathml file. If given only
+;; one argument the result goes to standard output.
+
+;; Method:
+
+;; Producing MathML from a macsyma internal expression is done by
+;; a reversal of the parsing process. Fundamentally, a
+;; traversal of the expression tree is produced by the program,
+;; with appropriate substitutions and recognition of the
+;; infix / prefix / postfix / matchfix relations on symbols. Various
+;; changes are made to this so that MathML will like the results.
+
+;; Instructions:
+;; in macsyma, type mathml(<expression>); or mathml(<label>); or
+;; mathml(<expr-or-label>, <file-name>); In the case of a label,
+;; an equation-number will also be produced.
+;; in case a file-name is supplied, the output will be sent
+;; (perhaps appended) to that file.
+
+(macsyma-module mathml)
+
+#+franz
+($bothcases t) ;; allow alpha and Alpha to be different
+(declare-top
+ (special lop rop ccol $gcprint texport $labels $inchar
+ vaxima-main-dir
+ )
+ (*expr mathml-lbp mathml-rbp))
+
+;; top level command the result of converting the expression x.
+
+(defmspec $mathml(l) ;; mexplabel, and optional filename
+ ;;if filename supplied but 'nil' then return a string
+ (let ((args (cdr l)))
+ (cond ((and (cdr args) (null (cadr args)))
+ (let ((*standard-output* (make-string-output-stream)))
+ (apply 'mathml1 args)
+ (get-output-stream-string *standard-output*)
+ )
+ )
+ (t (apply 'mathml1 args)))))
+
+(defun mathml1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
+ (prog (mexp texport $gcprint ccol x y itsalabel tmpport)
+ ;; $gcprint = nil turns gc messages off
+ (setq ccol 1)
+ (cond ((null mexplabel)
+ (displa " No eqn given to MathML")
+ (return nil)))
+ ;; collect the file-name, if any, and open a port if needed
+ (setq texport (cond((null filename) *standard-output* ); t= output to terminal
+ (t
+ (open (string (stripdollar filename))
+ :direction :output
+ :if-exists :append
+ :if-does-not-exist :create))))
+ ;; go back and analyze the first arg more thoroughly now.
+ ;; do a normal evaluation of the expression in macsyma
+ (setq mexp (meval mexplabel))
+ (cond ((memq mexplabel $labels); leave it if it is a label
+ (setq mexplabel (concat "(" (stripdollar mexplabel) ")"))
+ (setq itsalabel t))
+ (t (setq mexplabel nil)));flush it otherwise
+
+ ;; maybe it is a function?
+ (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
+ (setq x ($verbify x))
+ (cond ((setq y (mget x 'mexpr))
+ (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'mmacro))
+ (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'aexpr))
+ (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
+ (cond ((and (null (atom mexp))
+ (memq (caar mexp) '(mdefine mdefmacro)))
+ (format texport "<pre>~%" )
+ (cond (mexplabel (format texport "~a " mexplabel)))
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ ((and
+ itsalabel ;; but is it a user-command-label?
+ (eq (getchar $inchar 2) (getchar mexplabel 2)))
+ ;; aha, this is a C-line: do the grinding:
+ (format texport "<pre>~%~a " mexplabel)
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ (t ; display the expression for MathML now:
+ (myprinc "<math xmlns='http://www.w3.org/1998/Math/MathML'> ")
+ (mapc #'myprinc
+ ;;initially the left and right contexts are
+ ;; empty lists, and there are implicit parens
+ ;; around the whole expression
+ (mathml mexp nil nil 'mparen 'mparen))
+ (cond (mexplabel
+ (format texport "<mspace width='verythickmathspace'/> <mtext>~a</mtext> " mexplabel)))
+ (format texport "</math>")))
+ (cond(filename(terpri texport); and drain port if not terminal
+ (close texport)))
+ (return mexplabel)))
+
+(defun mathml (x l r lop rop)
+ ;; x is the expression of interest; l is the list of strings to its
+ ;; left, r to its right. lop and rop are the operators on the left
+ ;; and right of x in the tree, and will determine if parens must
+ ;; be inserted
+ (setq x (nformat x))
+ (cond ((atom x) (mathml-atom x l r))
+ ((or (<= (mathml-lbp (caar x)) (mathml-rbp lop))
+ (> (mathml-lbp rop) (mathml-rbp (caar x))))
+ (mathml-paren x l r))
+ ;; special check needed because macsyma notates arrays peculiarly
+ ((memq 'array (cdar x)) (mathml-array x l r))
+ ;; dispatch for object-oriented mathml-ifiying
+ ((get (caar x) 'mathml) (funcall (get (caar x) 'mathml) x l r))
+ (t (mathml-function x l r nil))))
+
+(defun string-substitute (newstring oldchar x &aux matchpos)
+ (setq matchpos (position oldchar x))
+ (if (null matchpos) x
+ (concatenate 'string
+ (subseq x 0 matchpos)
+ newstring
+ (string-substitute newstring oldchar (subseq x (1+ matchpos))))))
+
+;;; NOTE that we try to include spaces after closing tags (e.g. "</mwhatever> ")
+;;; so that the line breaking algorithm in myprinc has some spaces where it
+;;; can choose to line break.
+
+;;; First we have the functions which are called directly by mathml and its
+;;; descendents
+
+(defun mathml-atom (x l r)
+ (append l
+ (list (cond ((numberp x) (mathmlnumformat x))
+ ((mstringp x) (string-left-trim '(#\&) x))
+ ((and (symbolp x) (get x 'mathmlword)))
+ (t (mathml-stripdollar x))))
+ r))
+
+(defun mathmlnumformat(atom)
+ (let (r firstpart exponent)
+ (cond ((integerp atom)
+ (strcat "<mn>" (format nil "~d" atom) "</mn> "))
+ (t
+ (setq r (explode atom))
+ (setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
+ (cond ((null exponent)
+ ;; it is not. go with it as given
+ (strcat "<mn>" (format nil "~s" atom) "</mn> "))
+ (t
+ (setq firstpart
+ (nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
+ (strcat
+ "<mrow><mn>"
+ (apply #'strcat firstpart)
+ "</mn><mo>×</mo> <msup><mn>10</mn><mn>"
+ (apply #'strcat (cdr exponent))
+ "</mn></msup> </mrow> ")
+ ))))))
+
+(defun mathml-stripdollar(sym)
+ (or (symbolp sym)
+ (return-from mathml-stripdollar sym))
+ (let* ((pname (string-left-trim '(#\$) (symbol-name sym)))
+ (l (length pname))
+ (begin-sub
+ (loop for i downfrom (1- l)
+ when (not (digit-char-p (aref pname i)))
+ do (return (1+ i)))))
+ (cond ((< begin-sub l) ;; need to do subscripting
+ (strcat "<msub><mi>"
+ (subseq pname 0 begin-sub)
+ "</mi> <mn>"
+ (subseq pname begin-sub l)
+ "</mn></msub> "))
+ (t ;; no subscripting needed
+ (strcat "<mi>" pname "</mi> ")))))
+
+(defun mathml-paren (x l r)
+ (mathml x (append l '("<mfenced separators=''>")) (cons "</mfenced> " r) 'mparen 'mparen))
+
+(defun mathml-array (x l r)
+ (let ((f))
+ (if (eq 'mqapply (caar x))
+ (setq f (cadr x)
+ x (cdr x)
+ l (mathml f (append l (list "<mfenced separators=','>"))
+ (list "</mfenced> ") 'mparen 'mparen))
+ (setq f (caar x)
+ l (mathml (mathmlword f) (append l '("<msub><mrow>")) nil lop 'mfunction)))
+ (setq
+ r (nconc (mathml-list (cdr x) nil (list "</mrow></msub> ") "<mo>,</mo>") r))
+ (nconc l (list "</mrow><mrow>") r )))
+
+;; set up a list , separated by symbols (, * ...) and then tack on the
+;; ending item (e.g. "]" or perhaps ")"
+(defun mathml-list (x l r sym)
+ (if (null x) r
+ (do ((nl))
+ ((null (cdr x))
+ (setq nl (nconc nl (mathml (car x) l r 'mparen 'mparen)))
+ nl)
+ (setq nl (nconc nl (mathml (car x) l (list sym) 'mparen 'mparen))
+ x (cdr x)
+ l nil))))
+
+;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
+;; operator
+(defun mathml-function (x l r op) op
+ (setq l (mathml (mathmlword (caar x)) l nil 'mparen 'mparen)
+ r (mathml (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
+ (nconc l r))
+
+;;; Now we have functions which are called via property lists
+
+(defun mathml-prefix (x l r)
+ (mathml (cadr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-infix (x l r)
+ ;; check for 2 args
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) l nil lop (caar x)))
+ (mathml (caddr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-postfix (x l r)
+ (mathml (cadr x) l (append (mathmlsym (caar x)) r) lop (caar x)))
+
+(defun mathml-nary (x l r)
+ (let* ((op (caar x)) (sym (mathmlsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
+ (cond ((null y) (mathml-function x l r t)) ; this should not happen
+ ((null (cdr y)) (mathml-function x l r t)) ; this should not happen, too
+ (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
+ ((null (cdr y)) (setq nl (nconc nl (mathml (car y) l r lop rop))) nl)
+ (setq nl (nconc nl (mathml (car y) l (list sym) lop rop))
+ y (cdr y)
+ l nil))))))
+
+(defun mathml-nofix (x l r) (mathml (caar x) l r (caar x) rop))
+
+(defun mathml-matchfix (x l r)
+ (setq l (append l (car (mathmlsym (caar x))))
+ ;; car of mathmlsym of a matchfix operator is the lead op
+ r (append (cdr (mathmlsym (caar x))) r)
+ ;; cdr is the trailing op
+ x (mathml-list (cdr x) nil r "<mo>,</mo>"))
+ (append l x))
+
+(defun mathmlsym (x) (or (get x 'mathmlsym) (get x 'strsym)(get x 'dissym)
+ (stripdollar x)))
+
+(defun mathmlword (x)(or (get x 'mathmlword) (stripdollar x)))
+
+(defprop bigfloat mathml-bigfloat mathml)
+
+(defun mathml-bigfloat (x l r) (declare (ignore l r)) (fpformat x))
+
+(defprop mprog "<mi>block</mi><mspace width='mediummathspace'/> " mathmlword)
+(defprop %erf "<mi>erf</mi> " mathmlword)
+(defprop $erf "<mi>erf</mi> " mathmlword) ;; etc for multicharacter names
+(defprop $true "<mi>true</mi> " mathmlword)
+(defprop $false "<mi>false</mi> " mathmlword)
+
+(defprop mprogn mathml-matchfix mathml) ;; mprogn is (<progstmnt>, ...)
+(defprop mprogn (("<mfenced separators=''>") "</mfenced> ") mathmlsym)
+
+(defprop mlist mathml-matchfix mathml)
+(defprop mlist (("<mfenced separators='' open='[' close=']'>")"</mfenced> ") mathmlsym)
+
+;;absolute value
+(defprop mabs mathml-matchfix mathml)
+(defprop mabs (("<mfenced separators='' open='|' close='|'>")"</mfenced> ") mathmlsym)
+
+(defprop mqapply mathml-mqapply mathml)
+
+(defun mathml-mqapply (x l r)
+ (setq l (mathml (cadr x) l (list "(" ) lop 'mfunction)
+ r (mathml-list (cddr x) nil (cons ")" r) "<mo>,</mo>"))
+ (append l r));; fixed 9/24/87 RJF
+
+(defprop $%i "<mi>ⅈ</mi> " mathmlword)
+(defprop $%pi "<mi>π</mi> " mathmlword)
+(defprop $%e "<mi>ⅇ</mi> " mathmlword)
+(defprop $inf "<mi>∞</mi> " mathmlword)
+(defprop $minf "<mi>-∞</mi> " mathmlword)
+(defprop %laplace "<mo>ℒ</mo>" mathmlword)
+(defprop $alpha "<mi>α</mi> " mathmlword)
+(defprop $beta "<mi>β</mi> " mathmlword)
+(defprop $gamma "<mi>γ</mi> " mathmlword)
+(defprop %gamma "<mi>Γ</mi> " mathmlword)
+(defprop $delta "<mi>δ</mi> " mathmlword)
+(defprop $epsilon "<mi>ε</mi> " mathmlword)
+(defprop $zeta "<mi>ζ</mi> " mathmlword)
+(defprop $eta "<mi>η</mi> " mathmlword)
+(defprop $theta "<mi>θ</mi> " mathmlword)
+(defprop $iota "<mi>ι</mi> " mathmlword)
+(defprop $kappa "<mi>κ</mi> " mathmlword)
+;(defprop $lambda "<mi>λ</mi> " mathmlword)
+(defprop $mu "<mi>μ</mi> " mathmlword)
+(defprop $nu "<mi>ν</mi> " mathmlword)
+(defprop $xi "<mi>ξ</mi> " mathmlword)
+(defprop $pi "<mi>π</mi> " mathmlword)
+(defprop $rho "<mi>ρ</mi> " mathmlword)
+(defprop $sigma "<mi>σ</mi> " mathmlword)
+(defprop $tau "<mi>τ</mi> " mathmlword)
+(defprop $upsilon "<mi>υ</mi> " mathmlword)
+(defprop $phi "<mi>φ</mi> " mathmlword)
+(defprop $chi "<mi>χ</mi> " mathmlword)
+(defprop $psi "<mi>ψ</mi> " mathmlword)
+(defprop $omega "<mi>ω</mi> " mathmlword)
+
+(defprop mquote mathml-prefix mathml)
+(defprop mquote ("<mo>'</mo>") mathmlsym)
+(defprop mquote 201. mathml-rbp)
+
+(defprop msetq mathml-infix mathml)
+(defprop msetq ("<mo>:</mo>") mathmlsym)
+(defprop msetq 180. mathml-rbp)
+(defprop msetq 20. mathml-rbp)
+
+(defprop mset mathml-infix mathml)
+(defprop mset ("<mo>::</mo>") mathmlsym)
+(defprop mset 180. mathml-lbp)
+(defprop mset 20. mathml-rbp)
+
+(defprop mdefine mathml-infix mathml)
+(defprop mdefine ("<mo>:=</mo>") mathmlsym)
+(defprop mdefine 180. mathml-lbp)
+(defprop mdefine 20. mathml-rbp)
+
+(defprop mdefmacro mathml-infix mathml)
+(defprop mdefmacro ("<mo>::=</mo>") mathmlsym)
+(defprop mdefmacro 180. mathml-lbp)
+(defprop mdefmacro 20. mathml-rbp)
+
+(defprop marrow mathml-infix mathml)
+(defprop marrow ("<mo>→</mo>") mathmlsym)
+(defprop marrow 25 mathml-lbp)
+(defprop marrow 25 mathml-rbp)
+
+(defprop mfactorial mathml-postfix mathml)
+(defprop mfactorial ("<mo>!</mo>") mathmlsym)
+(defprop mfactorial 160. mathml-lbp)
+
+(defprop mexpt mathml-mexpt mathml)
+(defprop mexpt 140. mathml-lbp)
+(defprop mexpt 139. mathml-rbp)
+
+(defprop %sum 110. mathml-rbp) ;; added by BLW, 1 Oct 2001
+(defprop %product 115. mathml-rbp) ;; added by BLW, 1 Oct 2001
+
+;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
+(defun mathml-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
+ (memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
+ (not (memq f '(%sum %product %derivative %integrate %at
+ %lsum %limit))) ;; 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 (mathml `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
+ (if (and (null (cdr bascdr))
+ (eq (get f 'mathml) 'mathml-prefix))
+ (setq r (mathml (car bascdr) nil r f 'mparen))
+ (setq r (mathml (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
+ (t nil))))) ; won't doit. fall through
+ (t (setq l (mathml (cadr x) (append l '("<msup><mrow>")) nil lop (caar x))
+ r (if (mmminusp (setq x (nformat (caddr x))))
+ ;; the change in base-line makes parens unnecessary
+ (if nc
+ (mathml (cadr x) '("</mrow> <mfenced separators='' open='<' close='>'> -")(cons "</mfenced></msup> " r) 'mparen 'mparen)
+ (mathml (cadr x) '("</mrow> <mfenced separators=''> -")(cons "</mfenced></msup> " r) 'mparen 'mparen))
+ (if nc
+ (mathml x (list "</mrow> <mfenced separators='' open='<' close='>'>")(cons "</mfenced></msup>" r) 'mparen 'mparen)
+ (if (and (numberp x) (< x 10))
+ (mathml x (list "</mrow> ")(cons "</msup> " r) 'mparen 'mparen)
+ (mathml x (list "</mrow> <mrow>")(cons "</mrow><mrow> " r) 'mparen 'mparen))
+ )))))
+ (append l r)))
+
+(defprop mncexpt mathml-mexpt mathml)
+
+(defprop mncexpt 135. mathml-lbp)
+(defprop mncexpt 134. mathml-rbp)
+
+(defprop mnctimes mathml-nary mathml)
+(defprop mnctimes "<mi>⋯</mi> " mathmlsym)
+(defprop mnctimes 110. mathml-lbp)
+(defprop mnctimes 109. mathml-rbp)
+
+(defprop mtimes mathml-nary mathml)
+(defprop mtimes "<mspace width='thinmathspace'/>" mathmlsym)
+(defprop mtimes 120. mathml-lbp)
+(defprop mtimes 120. mathml-rbp)
+
+(defprop %sqrt mathml-sqrt mathml)
+
+(defun mathml-sqrt(x l r)
+ ;; format as \\sqrt { } assuming implicit parens for sqr grouping
+ (mathml (cadr x) (append l '("<msqrt>")) (append '("</msqrt>") r) 'mparen 'mparen))
+
+;; macsyma doesn't know about cube (or nth) roots,
+;; but if it did, this is what it would look like.
+(defprop $cubrt mathml-cubrt mathml)
+
+(defun mathml-cubrt (x l r)
+ (mathml (cadr x) (append l '("<mroot><mrow>")) (append '("</mrow>3</mroot>") r) 'mparen 'mparen))
+
+(defprop mquotient mathml-mquotient mathml)
+(defprop mquotient ("<mo>/</mo>") mathmlsym)
+(defprop mquotient 122. mathml-lbp) ;;dunno about this
+(defprop mquotient 123. mathml-rbp)
+
+(defun mathml-mquotient (x l r)
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) (append l '("<mfrac><mrow>")) nil 'mparen 'mparen)
+ r (mathml (caddr x) (list "</mrow> <mrow>") (append '("</mrow></mfrac> ")r) 'mparen 'mparen))
+ (append l r))
+
+(defprop $matrix mathml-matrix mathml)
+
+(defun mathml-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
+ (append l `("<mfenced separators='' open='(' close=')'><mtable>")
+ (mapcan #'(lambda(y)
+ (mathml-list (cdr y) (list "<mtr><mtd>") (list "</mtd></mtr> ") "</mtd><mtd>"))
+ (cdr x))
+ '("</mtable></mfenced> ") r))
+
+;; macsyma sum or prod is over integer range, not low <= index <= high
+;; Mathml is lots more flexible .. but
+
+(defprop %sum mathml-sum mathml)
+(defprop %lsum mathml-lsum mathml)
+(defprop %product mathml-sum mathml)
+
+;; easily extended to union, intersect, otherops
+
+(defun mathml-lsum(x l r)
+ (let ((op (cond ((eq (caar x) '%lsum) "<mrow><munder><mo>∑</mo> <mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow></munder> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defun mathml-sum(x l r)
+ (let ((op (cond ((eq (caar x) '%sum) "<mrow><munderover><mo>∑</mo><mrow>")
+ ((eq (caar x) '%product) "<mrow><munderover><mo>∏</mo><mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
+ (toplim (mathml (car(cddddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow> <mrow>" ,@toplim "</mrow></munderover> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defprop %integrate mathml-int mathml)
+
+(defun mathml-int (x l r)
+ (let ((s1 (mathml (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
+ (var (mathml (caddr x) nil nil 'mparen rop))) ;; variable
+ (cond((= (length x) 3)
+ (append l `("<mrow><mo>∫</mo><mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi></mrow></mrow> ") r))
+ (t ;; presumably length 5
+ (let ((low (mathml (nth 3 x) nil nil 'mparen 'mparen))
+ ;; 1st item is 0
+ (hi (mathml (nth 4 x) nil nil 'mparen 'mparen)))
+ (append l `("<mrow><munderover><mo>∫</mo> <mrow>" ,@low "</mrow> <mrow>" ,@hi "</mrow> </munderover> <mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi> </mrow></mrow> ") r))))))
+
+(defprop %limit mathml-limit mathml)
+
+(defprop mrarr mathml-infix mathml)
+(defprop mrarr ("<mo>→</mo> ") mathmlsym)
+(defprop mrarr 80. mathml-lbp)
+(defprop mrarr 80. mathml-rbp)
+
+(defun mathml-limit(x l r) ;; ignoring direction, last optional arg to limit
+ (let ((s1 (mathml (second x) nil nil 'mparen rop));; limitfunction
+ (subfun ;; the thing underneath "limit"
+ (mathml `((mrarr simp) ,(third x) ,(fourth x)) nil nil 'mparen 'mparen)))
+ (append l `("<munder><mo>lim</mo><mrow>" ,@subfun "</mrow> </munder> <mrow>" ,@s1 "</mrow>") r)))
+
+(defprop %at mathml-at mathml)
+
+;; e.g. at(diff(f(x)),x=a)
+(defun mathml-at (x l r)
+ (let ((s1 (mathml (cadr x) nil nil lop rop))
+ (sub (mathml (caddr x) nil nil 'mparen 'mparen)))
+ (append l '("<msub><mfenced separators='' open='' close='|'>") s1 '("</mfenced> <mrow>") sub '("</mrow> </msub> ") r)))
+
+;;binomial coefficients
+
+(defprop %binomial mathml-choose mathml)
+
+(defun mathml-choose (x l r)
+ `(,@l
+ "<mfenced separators='' open='(' close=')'><mtable><mtr><mtd>"
+ ,@(mathml (cadr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> <mtr><mtd>"
+ ,@(mathml (caddr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> </mtable></mfenced> "
+ ,@r))
+
+
+(defprop rat mathml-rat mathml)
+(defprop rat 120. mathml-lbp)
+(defprop rat 121. mathml-rbp)
+(defun mathml-rat(x l r) (mathml-mquotient x l r))
+
+(defprop mplus mathml-mplus mathml)
+(defprop mplus 100. mathml-lbp)
+(defprop mplus 100. mathml-rbp)
+
+(defun mathml-mplus (x l r)
+ ;(declare (fixnum w))
+ (cond ((memq 'trunc (car x))(setq r (cons "<mo>+</mo><mtext>⋯</mtext> " r))))
+ (cond ((null (cddr x))
+ (if (null (cdr x))
+ (mathml-function x l r t)
+ (mathml (cadr x) (cons "<mo>+</mo>" l) r 'mplus rop)))
+ (t (setq l (mathml (cadr x) l nil lop 'mplus)
+ x (cddr x))
+ (do ((nl l) (dissym))
+ ((null (cdr x))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq r (mathml l dissym r 'mplus rop))
+ (append nl r))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq nl (append nl (mathml l dissym nil 'mplus 'mplus))
+ x (cdr x))))))
+
+(defprop mminus mathml-prefix mathml)
+(defprop mminus ("-") mathmlsym)
+(defprop mminus 100. mathml-rbp)
+(defprop mminus 100. mathml-lbp)
+
+(defprop min mathml-infix mathml)
+(defprop min ("<mo>∈</mo> ") mathmlsym)
+(defprop min 80. mathml-lbp)
+(defprop min 80. mathml-rbp)
+
+(defprop mequal mathml-infix mathml)
+(defprop mequal ("<mo>=</mo> ") mathmlsym)
+(defprop mequal 80. mathml-lbp)
+(defprop mequal 80. mathml-rbp)
+
+(defprop mnotequal mathml-infix mathml)
+(defprop mnotequal 80. mathml-lbp)
+(defprop mnotequal 80. mathml-rbp)
+
+(defprop mgreaterp mathml-infix mathml)
+(defprop mgreaterp ("<mo>></mo> ") mathmlsym)
+(defprop mgreaterp 80. mathml-lbp)
+(defprop mgreaterp 80. mathml-rbp)
+
+(defprop mgeqp mathml-infix mathml)
+(defprop mgeqp ("<mo>≥</mo> ") mathmlsym)
+(defprop mgeqp 80. mathml-lbp)
+(defprop mgeqp 80. mathml-rbp)
+
+(defprop mlessp mathml-infix mathml)
+(defprop mlessp ("<mo><</mo> ") mathmlsym)
+(defprop mlessp 80. mathml-lbp)
+(defprop mlessp 80. mathml-rbp)
+
+(defprop mleqp mathml-infix mathml)
+(defprop mleqp ("<mo>≤</mo> ") mathmlsym)
+(defprop mleqp 80. mathml-lbp)
+(defprop mleqp 80. mathml-rbp)
+
+(defprop mnot mathml-prefix mathml)
+(defprop mnot ("<mo>¬</mo> ") mathmlsym)
+(defprop mnot 70. mathml-rbp)
+
+(defprop mand mathml-nary mathml)
+(defprop mand ("<mo>∧</mo> ") mathmlsym)
+(defprop mand 60. mathml-lbp)
+(defprop mand 60. mathml-rbp)
+
+(defprop mor mathml-nary mathml)
+(defprop mor ("<mo>∨</mo> ") mathmlsym)
+
+;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
+;; etc
+
+(defun mathml-setup (x)
+ (let((a (car x))
+ (b (cadr x)))
+ (setf (get a 'mathml) 'mathml-prefix)
+ (setf (get a 'mathmlword) b) ;This means "sin" will always be roman
+ (setf (get a 'mathmlsym) (list b))
+ (setf (get a 'mathml-rbp) 130)))
+
+(mapc #'mathml-setup
+ '(
+ (%acos "<mi>arccos</mi> ")
+ (%asin "<mi>arcsin</mi> ")
+ (%atan "<mi>arctan</mi> ")
+ (%arg "<mi>arg</mi> ")
+ (%cos "<mi>cos</mi> ")
+ (%cosh "<mi>cosh</mi> ")
+ (%cot "<mi>cot</mi> ")
+ (%coth "<mi>coth</mi> ")
+ (%csc "<mi>cosec</mi> ")
+ (%deg "<mi>deg</mi> ")
+ (%determinant "<mi>det</mi> ")
+ (%dim "<mi>dim</mi> ")
+ (%exp "<mi>exp</mi> ")
+ (%gcd "<mi>gcd</mi> ")
+ (%hom "<mi>hom</mi> ")
+ (%inf "<mi>∞</mi> ")
+ (%ker "<mi>ker</mi> ")
+ (%lg "<mi>lg</mi> ")
+ ;;(%limit "<mi>lim</mi> ")
+ (%liminf "<mi>lim inf</mi> ")
+ (%limsup "<mi>lim sup</mi> ")
+ (%ln "<mi>ln</mi> ")
+ (%log "<mi>log</mi> ")
+ (%max "<mi>max</mi> ")
+ (%min "<mi>min</mi> ")
+ ; Latex's "Pr" ... ?
+ (%sec "<mi>sec</mi> ")
+ (%sech "<mi>sech</mi> ")
+ (%sin "<mi>sin</mi> ")
+ (%sinh "<mi>sinh</mi> ")
+ (%sup "<mi>sup</mi> ")
+ (%tan "<mi>tan</mi> ")
+ (%tanh "<mi>tanh</mi> ")
+ ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
+ ;(%laplace "{\\cal L}")
+ )) ;; etc
+
+(defprop mor mathml-nary mathml)
+(defprop mor 50. mathml-lbp)
+(defprop mor 50. mathml-rbp)
+
+(defprop mcond mathml-mcond mathml)
+(defprop mcond 25. mathml-lbp)
+(defprop mcond 25. mathml-rbp)
+
+(defprop %derivative mathml-derivative mathml)
+
+(defun mathml-derivative (x l r)
+ (mathml (mathml-d x "ⅆ") l r lop rop ))
+
+(defun mathml-d(x dsym) ;dsym should be "ⅆ" or "∂"
+ ;; 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '(mtimes)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mtimes)
+ ((mquotient) ,(simplifya numer nil) ,denom)
+ ,arg)))
+
+(defun mathml-mcond (x l r)
+ (append l
+ (mathml (cadr x) '("<mi>if</mi> <mspace width='mediummathspace'/>")
+ '("<mspace width='mediummathspace'/> <mi>then</mi><mspace width='mediummathspace'/> ") 'mparen 'mparen)
+ (if (eql (fifth x) '$false)
+ (mathml (caddr x) nil r 'mcond rop)
+ (append (mathml (caddr x) nil nil 'mparen 'mparen)
+ (mathml (fifth x) '("<mspace width='mediummathspace'/> <mi>else</mi><mspace width='mediummathspace'/> ") r 'mcond rop)))))
+
+(defprop mdo mathml-mdo mathml)
+(defprop mdo 30. mathml-lbp)
+(defprop mdo 30. mathml-rbp)
+(defprop mdoin mathml-mdoin mathml)
+(defprop mdoin 30. mathml-rbp)
+
+(defun mathml-lbp(x)(cond((get x 'mathml-lbp))(t(lbp x))))
+(defun mathml-rbp(x)(cond((get x 'mathml-rbp))(t(lbp x))))
+
+;; these aren't quite right
+
+(defun mathml-mdo (x l r)
+ (mathml-list (mathmlmdo x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathml-mdoin (x l r)
+ (mathml-list (mathmlmdoin x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathmlmdo (x)
+ (nconc (cond ((second x) `("<mi>for</mi> " ,(second x))))
+ (cond ((equal 1 (third x)) nil)
+ ((third x) `("<mi>from</mi> " ,(third x))))
+ (cond ((equal 1 (fourth x)) nil)
+ ((fourth x) `("<mi>step</mi> " ,(fourth x)))
+ ((fifth x) `("<mi>next</mi> " ,(fifth x))))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+(defun mathmlmdoin (x)
+ (nconc `("<mi>for</mi>" ,(second x) "<mi>in</mi> " ,(third x))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+;; Undone and trickier:
+;; Maybe do some special hacking for standard notations for
+;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
diff --git a/stack/2017121800/maxima/multiply_blank.lisp b/stack/2017121800/maxima/multiply_blank.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8299d076a99df596824a75e72ac37c9cff2759dc
--- /dev/null
+++ b/stack/2017121800/maxima/multiply_blank.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\, ") texsym)
diff --git a/stack/2017121800/maxima/multiply_cross.lisp b/stack/2017121800/maxima/multiply_cross.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ec0052c83f44c454a238de0e579d79121ebf2f3b
--- /dev/null
+++ b/stack/2017121800/maxima/multiply_cross.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\times ") texsym)
diff --git a/stack/2017121800/maxima/multiply_dot.lisp b/stack/2017121800/maxima/multiply_dot.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fb7cb69891f68486972dd35d406fe5a2b79fe1f8
--- /dev/null
+++ b/stack/2017121800/maxima/multiply_dot.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\cdot ") texsym)
diff --git a/stack/2017121800/maxima/noun_arith.lisp b/stack/2017121800/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3ffda4a9b0b67068f7d0b8ba9291b3b35212fbf1
--- /dev/null
+++ b/stack/2017121800/maxima/noun_arith.lisp
@@ -0,0 +1,47 @@
+;; 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)
+
+;; Chris Sangwin 3 Feb 2016.
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ and }}\\, ") texsym)
+(defprop $nounand 69. tex-lbp)
+(defprop $nounand 69. tex-rbp)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ or }}\\, ") texsym)
+(defprop $nounor 70. tex-lbp)
+(defprop $nounor 70. tex-rbp)
+
+;; Chris Sangwin 29 Sept 2017.
+
+(defprop mnot tex-prefix tex)
+(defprop mnot ("{\\rm not}") texsym)
\ No newline at end of file
diff --git a/stack/2017121800/maxima/rtest_assessment_simpboth.mac b/stack/2017121800/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bc02f607f7cb9219dbadde904a5e70c875460a14
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/rtest_assessment_simpfalse.mac b/stack/2017121800/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/rtest_assessment_simptrue.mac b/stack/2017121800/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6f71fbf308f39067a419f103f2f6e41a93f1d725
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/rtest_elementary.mac b/stack/2017121800/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/rtest_experimental.mac b/stack/2017121800/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/stack/2017121800/maxima/rtest_inequalities.mac b/stack/2017121800/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2498d27574c6e7dc113cb932b6f23b37ce4a1214
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/rtest_intervals.mac b/stack/2017121800/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2e72d77091c1fb56eba98f1d12cbbc7a692ced3b
--- /dev/null
+++ b/stack/2017121800/maxima/rtest_intervals.mac
@@ -0,0 +1,62 @@
+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+x^2+1/(x+1));
+realset(x,%union(oo(-1,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)))$
+
+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;
\ No newline at end of file
diff --git a/stack/2017121800/maxima/sandbox.wxm b/stack/2017121800/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..8162b8c7b20469febe2605e9c84020b5446d960a
--- /dev/null
+++ b/stack/2017121800/maxima/sandbox.wxm
@@ -0,0 +1,67 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 15.08.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. Download the files from github, either using git or as a zip file.
+2. Place the files somewhere they can be read, and edit the line velow to give the location.
+ E.g. Place the files in C:\files\stack
+3. Specify a directory for temporary working files, e.g. 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 ] */
+/* In MS platforms use the forward slash as a directory seperator. No trailing slash. */
+stacklocation:"C:/files/stack"$
+stacktmplocation:"C:/tmp"$
+
+/****************************************************
+ There should be no need to edit below this line.
+
+ These commands add the location to Maxima's search path.
+*/
+file_search_maxima:append( [sconcat(stacklocation, "/question/type/stack/stack/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/question/type/stack/stack/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:38.3,
+ MAXIMA_PLATFORM:"win",
+ 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.41.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 ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2017121800/maxima/stackmaxima.mac b/stack/2017121800/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f7429bccf081237061a799f3148100a215052d7d
--- /dev/null
+++ b/stack/2017121800/maxima/stackmaxima.mac
@@ -0,0 +1,2780 @@
+/* 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(rand_seed) := block(
+ 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,
+ 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),
+
+ /*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(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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(1000);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* 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. */
+
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+load ("functs");
+
+/* 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");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+alias(arccos, acos); /* At the request of the OU, 4 Feb 2013. */
+alias(arcsin, asin);
+alias(arctan, atan);
+
+load("mathml.lisp");
+
+make_complexJ(OPT_COMPLEXJ) := block(
+ if OPT_COMPLEXJ = "i" then
+ (i:%i,load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "j" then
+ (%j:%i,j:%i,load("complexj.lisp"))
+ else if OPT_COMPLEXJ = "symi" then
+ (load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "symj" then
+ (load("complexj.lisp"))
+ else true
+);
+
+/* Choose the symbol for the multiplication sign. */
+make_multsgn(OPT_MULTSGN) := block(
+ if OPT_MULTSGN = "cross" then load("multiply_cross.lisp"),
+ if OPT_MULTSGN = "dot" then load("multiply_dot.lisp"),
+ if OPT_MULTSGN = "blank" then load("multiply_blank.lisp")
+);
+
+/* Options for cos^(-1), acos or arccos. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then load("cos-1.lisp"),
+ if OPT_ACOS = "arccos" then load("arccos.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))
+)$
+
+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 (
+ print("rand_selection error: first argument must be a list."),
+ return([])
+ ),
+ if not(integerp(n)) then (
+ print("rand_selection error: second argument must be an integer."),
+ return([])
+ ),
+ if is(n>length(ex)) then (
+ print("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 three 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(ex[2]-ex[1]), simp)),
+ if not(integerp(ex[3])) then error("rand_range expects its first argument to be an integer."),
+ if is(length(ex)=3) then return(ev(ex[1]+ex[3]*rand(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: forth 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 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: forth 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)))))
+)$
+
+/* ********************************** */
+/* 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"}), 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 = "d" then block(ld: "\\[", rd:"\\]"),
+ expstr: tex(expru, false),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* MathML display */
+ if OPT_OUTPUT = "MathML" then
+ str: mathml(expr, false),
+ /* 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
+ ev(printf(false, stackintfmt, x), simp) else
+ string(x);
+/* Some systems are throwing an error here, which is spurious. */
+errcatch(compile(?texnumformat));
+
+/* ********************************** */
+/* Display: Subscripts */
+/* ********************************** */
+
+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)))),
+ 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, "_"),
+ s: maplist(parse_string, 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)))
+)$
+
+/* ********************************** */
+/* 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)
+)$
+
+detexdecorate(ex) := block([argsex],
+ if mapatom(ex) then return(ex),
+ argsex:args(ex),
+ if op(ex) = texdecorate then return(detexdecorate(argsex[2])),
+ if op(ex) = "/" then return(detexdecorate(argsex[1])/detexdecorate(argsex[2])),
+ map(detexdecorate, ex)
+)$
+
+/* Assume all non-numeric atoms are to be displayed in bold. */
+texboldatoms(ex) := block(
+ if numberp(ex) then return(ex),
+ if atom(ex) then return(texdecorate("\\bf", ex)),
+ if arrayp(ex) then return(arraymake(op(ex), maplist(texboldatoms, args(ex)))),
+ apply(op(ex), maplist(texboldatoms, args(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 (print("\\mbox{ERROR: argument to stack_matrix_disp must be a matrix.} "), return("")),
+ if not(stringp(lmxchar)) then (print("\\mbox{ERROR: stack_matrix_disp requires lmxchar to be a string. }"), return("")),
+ parens: sublist(stack_matrix_pairs, lambda([ex], is(first(ex)=lmxchar))),
+ if emptyp(parens) then (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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) then return(ex),
+ ex2: unary_minus_traverse(ex),
+ return(unary_minus_pull(ex2))
+)$
+
+/* ********************************************************************* */
+/* 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(
+ ex: detexcolor(ex),
+ ex: detexdecorate(ex),
+ ex: make_displaydpvalue(ex),
+ ex: make_displayscivalue(ex),
+ ex: opsubst("*", stackunits, ex),
+ return(string(ex))
+)$
+
+/* ********************************** */
+/* 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: concat(fb, "stack_trans('", key, "'", exprs, "); !NEWLINE!"),
+ return(str)
+)$
+
+/* Separate notes with puncutation, to enable clearer reading
+ and the possibility to split them. */
+StackAddNote(exnote, 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)]$
+
+/* ********************************************************* */
+/* Turns answertest output to a STACK return object string */
+/* */
+/* ex[1] = validity should be true/false */
+/* ex[2] = result should be true/false, */
+/* ex[3] = feedback, a string */
+/* ex[4] = answernote, is for teacher stats */
+/* */
+/* ********************************************************* */
+
+StackReturn(ex) := block([str],
+ if not(listp(ex)) then
+ (print("StackReturn failed: argument not a list: "), print(string(ex)), return("")),
+ if length(ex)#4 then
+ (print("StackReturn failed: argument wrong length: "), print(string(ex)), return("")),
+ print(" ], valid = [ "),
+ if ex[1] then print(1) else print(0),
+ print(" ], answernote = [ "),
+ print(ex[3]),
+ print(" ], feedback = [ "),
+ print(ex[4]),
+ return(ex[2])
+)$
+
+/* 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 */
+/* ******************************************* */
+
+stack_validate(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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. */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms. */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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"))),
+ /* Check if the student's answer is the same type as the Teacher's. */
+ SameType:ATSameTypefun(expr, TAns),
+ if SameType[2]#true then print(SameType[4]),
+ /* Now display the result. */
+ simp: false,
+ expr: detexcolor(expr),
+ expr: detexdecorate(expr),
+ return(expr)
+)$
+
+/* Validate an expression without type checking. Floats and mathematical errors only. */
+stack_validate_typeless(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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 */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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)
+)$
+
+/* These functions convert all variables in an expression to products of single letter variable names. */
+stack_singlevar_make_helper(ex) := block([s],
+ s: maplist(eval_string, charlist(string(ex))),
+ apply("*", s)
+)$
+
+stack_singlevar_make(ex) := block([vars, subs],
+ vars: sublist(listofvars(ex), lambda([ex], if slength(string(ex))>1 then true else false)),
+ if emptyp(vars) then return(ex),
+ vars:maplist(lambda([ex], ex=stack_singlevar_make_helper(ex)), vars),
+ /* We only need to use associtativity of "*", not "+", but we have to do it over the whole expression. */
+ STACK_assoc(sublis(vars, ex), ["*"])
+)$
+
+/* 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],
+ 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(logbase, ex)) then
+ ex:ev(ex, logbase=logbasesimp),
+ lvs: listofvars(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ if length(lvs)>1 then
+ (print(concat("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /*********************/
+ /* 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ /*******************/
+ /* 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
+ (print(concat("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /********************************************/
+ /* 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='", alttext, "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class=\"stack_plot\">", ufn, "</div>"),
+ if OPT_OUTPUT#"MathML" then
+ 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(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"))]),
+
+ SA:sort(float(listify(SA))),
+ SB:sort(float(listify(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([Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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 not(integerp(nsf) and integerp(asf)) then
+ (print("TEST_FAILED"),return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* SA should be only a number. */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ SA:SAA[1],
+ if (not(floatnump(SA)) and not(integerp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* 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 not(is(sign(SA)=sign(SB))) 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.
+ This changes 1.5 -> 2.0 (2.s.f). */
+ SB:significantfigures(SB, nsf),
+ /* Puts Teacher's answer 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,
+ 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)
+)$
+
+/* ********************************** */
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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, eg 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([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 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 an equation? */
+ /* Don't use logic_edgep(SB) here, as this include "true" and "false". A teacher should use all/none if they mean equations. */
+ if (equationp(SB) or SB = all or SB = none) then
+ /* But the student can also use true/false here. Note the concious asymetry. */
+ if (equationp(SA) or logic_edgep(SA)) then
+ return(ATEquation(SA, SB))
+ else if equationp(SB) and not equationp(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, "+-"))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ /* Are we dealing with an inequality? */
+ if inequalityp(SB) then
+ if inequalityp(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)),
+ /* 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)
+)$
+
+/* 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]),
+ SA1:args(SA), SAd1:second(SA1),
+ SB1:args(SB), SBd1:second(SB1),
+ /* 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]),
+ FeedBack:StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i")),
+ if (SAr#SBr) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), FeedBack]),
+ if (SAc#SBc) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), FeedBack]),
+ FeedBack:"",
+ /* 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, str, SAl, SBl, ZM],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Get sizes of matrices */
+ SAl:cardinality(SA),
+ SBl:cardinality(SB),
+ FeedBack:StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i")),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ SA:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "d")),
+ return([true, false, StackAddNote("","ATSet_wrongentries"), 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,"+-")=1), simp) then SA:pm_replace(SA),
+ if ev(is(count_op(SB,"+-")=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, "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, "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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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 */
+ 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"),""]),
+
+ /* 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 not is(ev(setify(listofvars(S1)),simp)=ev(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, ""]) else
+ 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,""]) else
+ if op(SB) = "+" then return(irred_Q(SB, SO)) else
+ 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),
+ /* 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: StackReturn */
+/* 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:StackAddFeedback("",""), 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****************************** */
+/* requires: Student Answer */
+/* List: [Teachers Answer, variable with which partial */
+/* fraction occurs, whether Formative Feedback is required */
+/* returns: StackReturn */
+/* Cases: */
+/* Returns True iff algebraic equivalence with TList[1] */
+/* and Division is the Top Operator. */
+/* False if Division not the top operator */
+/* False if different Variables are used */
+/* True(0) otherwise */
+/* ******************************************************************** */
+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 op(SAA) = "/" then block(
+ if (freeof("/", num(SAA)) and freeof("/", denom(SAA))) then block(
+ rawmk:true,
+ ansnote:"ATSingleFrac_true")
+ else 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])
+)$
+
+
+/*****************************************************************/
+/* Useful function for Partial Fractions */
+/*****************************************************************/
+
+divthru(q) :=
+ if (not atom(q) and part(q,0)="/")
+ then
+ block([num, den, div, quo, rem],
+ num:part(q, 1),
+ den:part(q, 2),
+ div:divide(num, den) ,
+ quo:div[1],
+ rem:div[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(SBL[2], "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 */
+ 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])="^" 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"), ""]),
+
+ 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:"",
+ debug:false,
+ 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
+);
+
+/********************************************************************/
+/* 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:true, 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"),""]),
+
+ /* 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 algebraic_equivalence(diff(SA,v),int(SB,v)) 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)
+ )$
+
+/* ****************************************************** */
+/* */
+/* 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("")
+)$
+
+/* 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:2017121800$
diff --git a/stack/2017121800/maxima/stackreporting.mac b/stack/2017121800/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93
--- /dev/null
+++ b/stack/2017121800/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(
+ print("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/2017121800/maxima/stacktex.lisp b/stack/2017121800/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5e971bc03d25547fb1ea5ea93d2c0b0b05caf209
--- /dev/null
+++ b/stack/2017121800/maxima/stacktex.lisp
@@ -0,0 +1,349 @@
+;; 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)
+
+(defun tex-texdecorate (x l r)
+ (let
+ ((front (append '("{")
+ (list (stripdollar (cadr x)))
+ '("")))
+ (back (append '("{")
+ (tex (caddr x) nil nil 'mparen 'mparen)
+ '("}}"))))
+ (append l front back r)))
+
+(defprop $texdecorate tex-texdecorate 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '($blankmult)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom)
+ ))
+
+
+(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 $+-) :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))))
+
+
diff --git a/stack/2017121800/maxima/stacktex40.lisp b/stack/2017121800/maxima/stacktex40.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2f688179b2c7d0573e3db8a3caef343746f7fbae
--- /dev/null
+++ b/stack/2017121800/maxima/stacktex40.lisp
@@ -0,0 +1,91 @@
+;; 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 $+-) :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)))
+
+;; *************************************************************************************************
+;; 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) (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/2017121800/maxima/stackunits.mac b/stack/2017121800/maxima/stackunits.mac
new file mode 100644
index 0000000000000000000000000000000000000000..eb01d04b72e678f5887fd43fba609845a29ce870
--- /dev/null
+++ b/stack/2017121800/maxima/stackunits.mac
@@ -0,0 +1,570 @@
+/* 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}"],
+*/
+
+/* Add rules to the simplifier to deal with stackunits. */
+matchdeclare(STACKNUM1, all, STACKNUM2, all, STACKUNITS1, all, STACKUNITS2, all, STACKNUM, numberp)$
+matchdeclare(STACKANY, all)$
+tellsimpafter(STACKNUM*stackunits(STACKNUM1,STACKUNITS1), stackunits(STACKNUM*STACKNUM1, STACKUNITS1));
+tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)^STACKNUM, stackunits(STACKNUM1^STACKNUM, STACKUNITS1^STACKNUM));
+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)+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 is 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)="+-") 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 a product we are return what we are given. */
+ if 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(
+ print("fracdisp argument to stack_validate_units 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),
+
+ /* 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)="+-")) 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),
+ expr:detexdecorate(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 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. */
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "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, SAU1, SBU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ SAA:errcatch(ev(SA, simp, nouns)),
+ if (is_simp(SAA = [STACKERROR]) or is_simp(SAA = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is_simp(SBB = [STACKERROR]) or is_simp(SBB = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is_simp(SOO = [STACKERROR]) or is_simp(SOO = [])) 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 (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU)),
+
+ /* 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, ol])),
+ if (numtest = "SigFigs") then
+ ret1: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret1: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret1: ATNumRelative(SAU1, SBU1, ol)
+ 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]]),
+
+ /* 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),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(SB),
+ if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU)),
+ /* Check the accuracy again, now we have converted. */
+ SAU1:ev(float(stack_units_nums(SAU)), simp),
+ SBU1:ev(float(stack_units_nums(SBU)), simp),
+ if (numtest = "SigFigs") then
+ ret2: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret2: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret2: ATNumRelative(SAU1, SBU1, ol)
+ 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/2017121800/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2017121800/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d4e798fd0706ced74f70dd61ce6c9a3d2f943b85
--- /dev/null
+++ b/stack/2017121800/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/2017121800/maxima/unittests_load.mac b/stack/2017121800/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f124a05080e9a19066059a4dfe03ed92aeb116e6
--- /dev/null
+++ b/stack/2017121800/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 */
+
+kill(all);
+LOADDIR:"/home/sangwinc/Documents/linuxnotes/moodle27.mac"$
+LOADDIR:"/var/data/moodle_equiv/equiv/stack/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/2017121800/maxima/utils.mac b/stack/2017121800/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..940f0fadcf9004fd103dfc8713dfb71d86ad3f35
--- /dev/null
+++ b/stack/2017121800/maxima/utils.mac
@@ -0,0 +1,115 @@
+/* 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)
+)$
+
+
+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/2018030500/maxima/arccos.lisp b/stack/2018030500/maxima/arccos.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..963ff6b45f83923546f7163cc973266c91102e7e
--- /dev/null
+++ b/stack/2018030500/maxima/arccos.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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/2018030500/maxima/assessment.mac b/stack/2018030500/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..23f70ed46200fe6661772b36742fe0dc5ad05550
--- /dev/null
+++ b/stack/2018030500/maxima/assessment.mac
@@ -0,0 +1,1888 @@
+/* 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/>. */
+
+
+/****************************************************************/
+/* An assessment package for Maxima */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.7 September 2015 */
+/* */
+/****************************************************************/
+
+MAXIMA_VERSION:map(parse_string, tokens(?\*autoconf\-version\*, 'digitcharp))$
+MAXIMA_VERSION_NUM:float(MAXIMA_VERSION[2]+(if is(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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],
+ 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
+);
+
+/* 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)$
+
+/* ********************************** */
+/* 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)
+)$
+
+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) 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);
+
+/* Add in support for logarithms to an arbirary base. */
+lg([ex]) := block(
+ if length(ex) = 1 then return(logbase(first(ex), 10)),
+ if length(ex) = 2 then return(logbase(first(ex), second(ex))),
+ error("STACK function 'lg' must have one or two arguments only.")
+)$
+
+logbasetex(ex) := block([n, b],
+ [n, b]:args(ex),
+ oldsimp:simp,
+ return(concat("\\log_{", stack_disp_strip_dollars(tex(b, false)), "}\\left(", stack_disp_strip_dollars(tex(n, false)), "\\right)"))
+)$
+texput(logbase, logbasetex);
+
+/* Use of radcan to give canonical form. */
+logbasesimp(n,b) := radcan(log(n)/log(b));
+
+/* 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), logbase=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)
+)$
+
+/* 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)
+)$
+
+/* 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)), logbase=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 not(real_numberp(x)) then error("sigfigsfun(x,n,d) requires a real number 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 thrid 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), logbase=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([a]) := block([simp:false, x, ex, ex2, ex3, exn],
+ 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), logbase=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),
+ return(ex3)
+ ),
+ 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.
+*/
+
+
+/* ********************************** */
+/* 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/9/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.
+*/
+algebraic_equivalence(SA, SB) :=
+ block([keepfloat, trigexpand, logexpand, ex, vi],
+ /* Reject obviously different expressions. These can be very time consuming in the tests below. */
+ /* The code below is actually making the situation worse: needs reconsidering. */
+ if numerical_not_alg_equiv(SA, SB) then return(false),
+ trigexpand:true,
+ 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 scientific units and displaydp from expressions. */
+ SA:ev(SA, stackunits="*"),
+ SB:ev(SB, stackunits="*"),
+ 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(logbase, SA)) then
+ SA:ev(SA, logbase=logbasesimp),
+ if not(freeof(logbase, SB)) then
+ SB:ev(SB, logbase=logbasesimp),
+ /* Try not to expand out: pure numbers. */
+ ex:errcatch(ev(SA-SB, simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: factoring the difference of two expressions threw an error."), return(false)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ ex:errcatch(ratsimp(ex)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 */
+ 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],
+ /* 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 is(pval = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ if abs(first(pval)) > 1/10000 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)),
+ sz:errcatch(ev(abs(float(first(p1)-first(p2))), 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);
+
+verb_arith(ex) := block(
+ 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(
+ 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))))),
+ apply(op(ex), maplist(flatten_recurse_nouns, args(ex)))
+)$
+
+/* 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, ex1n, ex2n, ret],
+ oldsimp:simp,
+ simp:false,
+ ex1n:noun_arith(ex1),
+ ex2n:noun_arith(ex2),
+ simp:true,
+ ex1n:ev(flatten_recurse_nouns(ex1n), simp),
+ ex2n:ev(flatten_recurse_nouns(ex2n), simp),
+ if ex1n=ex2n then ret:true else ret:false,
+ simp:oldsimp,
+ ret
+)$
+
+/* An answer test in the context of commutative+associative addition and multiplication. */
+ATEqualComAss(sa, sb) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB],
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]),
+
+ /* We need 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)$
+
+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) = "and" then return(true),
+ if safe_op(ex) = "or" then return(true),
+ if safe_op(ex) = "not" then return(true),
+ if op_usedp(ex, "+-") 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", "and", "or", "%and", "%or", "not", "%not", "+-", "<", ">", "<=", ">=", "=", "[", "{"],
+ 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:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", ex),
+ ex:subst("%and", "and", ex),
+ ex:subst("%or", "or", ex),
+ ex:de_morgan(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)
+)$
+
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ return(rex)
+)$
+
+/****************************************************************/
+/* Define noun versions of other functions */
+/****************************************************************/
+
+nounint([ex]):=apply(nounify(integrate), ex)$
+noundiff([ex]):=apply(nounify(diff), ex)$
+
+/* ********************************** */
+/* Add in a +- operator */
+/* ********************************** */
+
+/* We have to define +- to be both a prefix and an nary operator in this order. */
+prefix("+-");
+nary("+-", 100);
+
+displaypmtex(ex):=block([al, a1, a2],
+ al:args(ex),
+ if is(length(al)=1) then
+ return(sconcat(" \\pm ", tex1(first(al)))),
+ a1:tex1(first(al)),
+ a2:tex1(second(al)),
+ sconcat("{", a1, " \\pm ", a2, "}")
+ );
+texput("+-", 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, "+-")=1), simp) then return(opsubst("+", "+-", ex) nounor opsubst("-", "+-", 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 ev(argfac=factor(argfac), simp) then
+ return(true),
+ if mapatom(argfac) then
+ return(false),
+ /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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 (
+ print("comp_square: var should be an atom but not a number. "),
+ return(ex)
+ ),
+ ex:ratsimp(expand(ex)),
+ if not(polynomialp(ex, [var])) then (
+ print("comp_square: ex should be a polynomial in var. "),
+ return(ex)
+ ),
+ if hipow(ex, var)#2 then (
+ print("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 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 */
+/****************************/
+
+/*
+ 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
+)$
+
+addrow(m,i,j,k) := block([n,p],
+ require_matrix(m, "first", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_integer(j, "third", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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", "addrow"),
+ require_integer(i, "second", "addrow"),
+ require_rational(k, "fourth", "addrow"),
+ 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 : addrow (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(EQUIVCHARREAL, "\\color{green}{\\Leftrightarrow}\\, \\color{blue}{(\\mathbb{R})}");
+texput(CHECKMARK, "\\color{green}{\\checkmark}");
+texput(IMPLIESCHAR, "\\color{red}{\\Rightarrow}");
+texput(IMPLIEDCHAR, "\\color{red}{\\Leftarrow}");
+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, " ");
+
+
+/* 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 intert prefix equality symbol. */
+stackeqtex(ex):=block([ss, n, dp],
+ sconcat("=", tex1(first(args(ex))))
+);
+texput(stackeq, stackeqtex);
+
+/* 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 (print("stack_disp_arg expects to receive a list."), return(false)),
+ 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)),
+ exnatdomain:makelist(EMPTYCHAR, 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),
+ 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,"+-")=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, logbase=logbasesimp),
+ exmod[ev(id, simp)]:SA,
+
+ if ev(is(equal(length(listofvars(SA)),1)), simp) then
+ exmodsolve[ev(id, simp)]:ev(single_variable_solver_real(SA), simp)
+ else
+ exmodsolve[ev(id, simp)]:ev(logical_normal(SA), simp),
+
+ /* 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)),
+ if (debug) then print(SA),
+ if (debug) then print(SB),
+ if (debug) then print(SAP),
+ if (debug) then print(SBP),
+ if (debug) then print(SAS),
+ if (debug) then print(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 (
+ 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],
+ 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, 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(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 cause 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))
+ ),
+
+ /* 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))
+ )
+ )
+ ),
+
+ /* Can we work out what has gone wrong? */
+ if (debug) then print("** Checking for common mistakes **"),
+ if (debug) then print(SA),
+ if (debug) then print(SB),
+ 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,
+
+ 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(
+ malrulecont:false,
+ eqoutcome[ev(id, simp)]:false,
+ eqoutsymb[ev(id, simp)]:IMPLIEDCHAR,
+ tempnote:sconcat(tempnote, " | SquaredSecond | ", 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. */
+ 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)
+ ),
+ res:matrix(eqoutcome, eqoutsymb, ex, exnatdomain, eqoutnote),
+ return(transpose(res))
+);
+
+/* This modifies stack_eval_arg to create something which can be displayed. */
+stack_eval_equiv_arg(ex, showlogic, 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
+ res:unknown
+ 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 (
+ print("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, equivdebug, debuglist) := block([A],
+ A:stack_eval_equiv_arg(ex, showlogic, equivdebug, debuglist),
+ return(second(A))
+)$
+
+/* This modifies stack_eval_arg to create something which can be displayed. */
+stack_disp_arg(ex, showlogic) := block([A],
+ A:stack_eval_equiv_arg(ex, showlogic, 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),
+ return(first(ret))
+)$
+
+/* An answer test based on equivalence reasoning. */
+ATEquiv(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack],
+
+ /* 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,
+
+ /* 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, 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],
+
+ /* 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,
+
+ /* 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, false, false),
+ AnswerNote:third(A),
+ FeedBack:stack_disp(second(A), "d"),
+
+ ret:[true, first(A), AnswerNote, FeedBack],
+ return(ret)
+)$
diff --git a/stack/2018030500/maxima/assessment.texi b/stack/2018030500/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/complexi.lisp b/stack/2018030500/maxima/complexi.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8be0972956d17463313be86ea1bd76f1b9552cbb
--- /dev/null
+++ b/stack/2018030500/maxima/complexi.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{i}" texword)
+
+(defprop $%i "<mi>i</mi> " mathmlword)
diff --git a/stack/2018030500/maxima/complexj.lisp b/stack/2018030500/maxima/complexj.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1fdfd5b91a8993b84fc72fd9f39114151c8dd4ce
--- /dev/null
+++ b/stack/2018030500/maxima/complexj.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{j}" texword)
+
+(defprop $%i "<mi>j</mi> " mathmlword)
diff --git a/stack/2018030500/maxima/cos-1.lisp b/stack/2018030500/maxima/cos-1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7cdb2e2d0c69d196c7ae93ea9c9f2740ece76b59
--- /dev/null
+++ b/stack/2018030500/maxima/cos-1.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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 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/2018030500/maxima/elementary.mac b/stack/2018030500/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..77cb7ddc99b1fb2410361c1cefb654b41cc414ed
--- /dev/null
+++ b/stack/2018030500/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 print("ERROR: 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/2018030500/maxima/expandfeedback.mac b/stack/2018030500/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/experimental.mac b/stack/2018030500/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..98afe06e41c2d99210e1ca9301fcd43e1b447811
--- /dev/null
+++ b/stack/2018030500/maxima/experimental.mac
@@ -0,0 +1,175 @@
+/* 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))));
+
+/****************************************************************/
+/* Inequality functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.2 July 2013 */
+/* */
+/****************************************************************/
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* 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 (print("STACK exception: node_no expects its first argument to be a list."), return(false)),
+ if not(integerp(num)) then (print("STACK exception: node_no expects its second argument to be an integer."), return(false)),
+ if is(length(prt)<num) then (print("STACK exception: node_no expects its second argument to less than the length of the first."), return(false)),
+ /* 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 (print("STACK exception: traverse_prt expects its argument to be a list."), return(false)),
+ if not(alllistp(equationp,inputs)) then (print("STACK exception: traverse_prt expects its argument to be a list of equations."), return(false)),
+ /* 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, <chris@sangwin.com> */
+/* 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/2018030500/maxima/inequalities.mac b/stack/2018030500/maxima/inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1a2af9cf84bf637bf62d129e3f17ca9a5d09a19d
--- /dev/null
+++ b/stack/2018030500/maxima/inequalities.mac
@@ -0,0 +1,304 @@
+/* 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 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:expand(ex),
+ /* 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 print("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],
+ 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/2018030500/maxima/intervals.mac b/stack/2018030500/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..0dc6c5a7f92aa4cedde0a85a49eb5febc651780f
--- /dev/null
+++ b/stack/2018030500/maxima/intervals.mac
@@ -0,0 +1,1030 @@
+/* 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 intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.2 June 2017 */
+/* */
+/********************************************************************/
+
+/* 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
+ );
+*/
+
+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(Complement(b), simp),
+ if 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)],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(false),
+ 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 setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(intervalp, args(ex))),
+ 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=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 atom(ex) then return(false),
+ if setp(ex) and ex={} then return(true),
+ if save_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)
+)$
+
+SimpleUnion(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 setp(A) then
+ (
+ if 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 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 setp(A) or atom(B) or 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:SimpleUnion( 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)
+ )
+ )
+ )
+ )
+ ),
+ if safe_op(Ans)="[" then Ans:apply(%union, Ans),
+ Ans
+ );
+
+
+/* Finds the intersection of two "simple" sets: */
+SimpleIntersect(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 Ans:{} elseif
+ atom(B) then Ans:{} elseif
+ setp(A) then
+ (
+ if setp(B) then
+ (
+ return(intersect(A,B))
+ )
+ else
+ (
+ 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:{}
+ )
+ )
+ elseif setp(B) then
+ (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do
+ (if inintervalp(Aset[i],A) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans:setAns ) else Ans:{}
+ ),
+ if ( not atom(A) and not atom(B) ) then
+ (
+ Args1:args(A),
+ Args2:args(B),
+
+ if (not atom(A) and not(op(A)=set) and not atom(B) and not(op(B)=set) ) 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:{},
+ 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
+ );
+
+SimpDisjointp(A,B) := if SimpleIntersect(A,B)={} then true else false;
+
+/* Given a *list* of disjoint intervals, returns the same intervals but in ascending order: */
+SortUnion(X) :=
+ block ( [A:X, Ans:[], x, n, i],
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ if ( first( A[i] ) < first( x ) ) then x:A[i],
+ i:i+1
+ ),
+ Ans:append( Ans, [x] ),
+ A:delete( x, A, 1 ),
+ n:n-1
+ ),
+ Ans
+ );
+
+/* Given a union of disjoint intervals, checks whether any intervals are connected, and if so, joins them up and returns the ammended union: */
+ConnectIntervals(X):=
+ block ( [Ans, n, x, y, i:1],
+
+ if not(op(X)=%union) then error("ConnectIntervals requires a %union of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ if last( Ans[i] ) >= first( Ans[i+1] ) then
+ (
+ x:SimpleUnion( Ans[i], Ans[i+1] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[i+1], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ Ans:SortUnion(Ans),
+ n:n-1,
+ i:i-1
+ )
+ ),
+ 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: */
+TidyUnion(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),
+
+ if (not (op(X)=%union or op(X)="[") ) then Ans:X
+ else
+ (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<n+1 do
+ (
+ if ( setp(A[i]) ) then
+ (
+ setpart:union( setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ )
+ else if ( trivialintervalp(A[i]) ) then
+ (
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ ),
+ i:i+1
+ ),
+ A:SortUnion(A),
+ if length(A)=1 then
+ Ans:apply(%union, A)
+ else
+ Ans:ConnectIntervals(apply(%union, A)),
+ if length(setpart)>0 then Ans:append( args(Ans), [setpart] )
+ ),
+ Ans
+ )$
+
+/* Finds the union of any two sets: */
+Union(X, Y) :=
+ block ( [A, B, Ans:[], Joined:[], sets:{}, add, temp, x, y, m, n, k, i:1, j:1, f:1],
+ if atom(X) then Ans:Y
+ elseif atom(Y) then Ans:X
+ else
+ (
+
+ A:X,
+ if op(X)=%union then A:args(X),
+ B:Y,
+ if op(Y)=%union then B:args(Y),
+
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleUnion(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:Union(A,B) )
+ else
+ (
+ while i<(m+1)do
+ (
+ if op( A[i] ) = set then
+ (
+ sets:SimpleUnion( sets , A[i] ),
+ A:delete( A[i] , A , 1 ),
+ i:i-1,
+ m:m-1
+ ),
+ i:i+1
+ ),
+ i:1,
+ while j<(n+1)do
+ (
+ if op( B[j] ) = set then
+ (
+ sets:SimpleUnion( sets , B[j] ),
+ B:delete( B[j] , B , 1 ),
+ j:j-1,
+ n:n-1
+ ),
+ j:j+1
+ ),
+ j:1,
+ temp:Ans,
+
+ Joined:append(A,B),
+ Joined:JoinedUnion(Joined),
+ temp:append(temp,Joined),
+
+ if length(sets)>0 then
+ (
+ sets:listify(sets),
+ m:length(temp),
+ n:length(sets),
+ while j<(n+1) do
+ (
+ while i<(m+1) do
+ (
+ x:first( temp[i] ),
+ y:last( temp[i] ),
+ if inintervalp( sets[j], temp[i] ) then
+ (
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ )
+ elseif ( sets[j]=x or sets[j]=y ) then
+ (
+ temp[i]:Union( temp[i], { sets[j] } ) ,
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ ),
+ i:i+1
+ ),
+ i:1,
+ j:j+1
+ ),
+ j:1,
+ if length(sets)>0 then
+ (
+ sets:setify(sets),
+ temp:cons(sets,temp)
+ )
+ ),
+ if length(temp)=1 then temp:temp[1],
+ Ans:temp
+ )
+ ),
+ Ans:TidyUnion(Ans)
+ ),
+
+ Ans
+ );
+
+/* When given a union of intervals, this function simplifies the union by joining up any connected intervals: */
+JoinedUnion(X) :=
+ block ( [A, nextA:[], disjoint:[], temp, Ans:[], n, i, j, alldisjoint:false, Joined:[] ],
+
+ A:X,
+ if op(A)=%union then A:args(A),
+ while alldisjoint = false do
+ (
+ alldisjoint:true,
+ n:length(A),
+ disjoint:[],
+ i:1,
+ while i<n+1 do
+ (
+ disjoint: append(disjoint, [true] ),
+ i:i+1
+ ),
+ i:1,
+ while i<n do
+ (
+ j:i+1,
+ while j<n+1 do
+ (
+ if ( SimpDisjointp( A[i], A[j] ) ) then
+ (
+ if disjoint[j] = true then
+ (
+ nextA:delete( A[j], nextA, 1),
+ nextA:append(nextA, [ A[j] ] )
+ )
+ )
+ else (
+ nextA:delete( A[i], nextA, 1),
+ nextA:delete( A[j], nextA, 1),
+ temp:SimpleUnion( A[i], A[j] ),
+ if ( not op(temp) = "[" ) then temp:[temp],
+ nextA:append(nextA, temp ),
+ disjoint[i]:false,
+ disjoint[j]:false,
+ alldisjoint:false
+ ),
+ j:j+1
+ ),
+ if disjoint[i] = true then
+ (
+ nextA:delete( A[i], nextA, 1 ),
+ nextA:append(nextA, [ A[i] ] )
+ ),
+ i:i+1
+ ),
+ if alldisjoint = false then A:nextA,
+ nextA:[]
+ ),
+ Ans:A,
+ Ans
+ );
+
+Intersection(X,Y) :=
+ block ([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if is(A=all) then return(B)
+ elseif is(B=all) then return(A)
+ elseif atom(A) then Ans:{}
+ elseif atom(B) then Ans:{}
+ else
+ (
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleIntersect(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:SimpleIntersect(A,B) )
+ else
+ (
+ while i<m+1 do
+ (
+ while j<n+1 do
+ (
+ temp:SimpleIntersect( A[i], B[j] ),
+ if not atom(temp) then
+ (
+ Ans:append( Ans, [temp] )
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ )
+ ),
+ if (not atom(Ans)) and op(Ans) = "[" then
+ (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ )
+ ),
+ Ans:TidyUnion(Ans),
+ Ans
+ );
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+ListIntersect(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:Intersection(Ans,A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+OrderPoints(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:TidyUnion(A),
+ if op( last(A) ) = set 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
+ );
+
+
+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( Ans:oo(-inf,inf) ),
+ if not (op(A) = "[" or op(A)=%union) then
+ (
+ if op(A)=set then Ans:SetComplement(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:OrderPoints(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(ListIntersect(maplist(lambda([ex2], TidyUnion(Complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ else if listp(Ans) then
+ Ans:apply(%union, Ans)
+ ),
+
+ Ans
+ );
+
+SetComplement(X):=
+ block ( [A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("SetComplement 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, simp],
+ 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),
+
+ simp:false,
+
+ 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("%and", "and", ex),
+ ex:subst("%or", "or", ex),
+
+ if assume_pos then block
+ (
+ ex:ex %and (v>=0)
+ ),
+ ex:de_morgan(ex),
+
+ ex:block([assume_pos:false], single_variable_solver_real_rec(ex, v)),
+
+ if ((safe_op(ex)="[" or safe_op(ex)="%union") and 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), realsetp), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realsetp(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, realsetp), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realsetp(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([TidyUnion(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([ListIntersect(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: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 not(is(length(v)=1)) then return(unknown),
+ /* We only work over real expressions. */
+ if not(is(freeof(%i, 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)="sum" then
+ return(unknown),
+ /* The variables inside this are local. */
+ if safe_op(ex)="int" then
+ return(unknown),
+ 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)="logbase" 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(realsetp(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:ListIntersect(ex2),
+ ex2
+)$
diff --git a/stack/2018030500/maxima/mathml.lisp b/stack/2018030500/maxima/mathml.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7671dad91e31b7c9b9caf64c27e3891e2d73e4c0
--- /dev/null
+++ b/stack/2018030500/maxima/mathml.lisp
@@ -0,0 +1,762 @@
+(in-package "MAXIMA")
+;; MathML-printing
+;; Created by David Drysdale (DMD), December 2002/January 2003
+;;
+;; closely based on the original TeX conversion code in mactex.lisp,
+;; for which the following credits apply:
+;; (c) copyright 1987, Richard J. Fateman
+;; small corrections and additions: Andrey Grozin, 2001
+;; additional additions: Judah Milgram (JM), September 2001
+;; additional corrections: Barton Willis (BLW), October 2001
+
+;; Usage: mathml(d8,"/tmp/foo.xml"); mathml(d10,"/tmp/foo.xml"); ..
+;; to append lines d8 and d10 to the mathml file. If given only
+;; one argument the result goes to standard output.
+
+;; Method:
+
+;; Producing MathML from a macsyma internal expression is done by
+;; a reversal of the parsing process. Fundamentally, a
+;; traversal of the expression tree is produced by the program,
+;; with appropriate substitutions and recognition of the
+;; infix / prefix / postfix / matchfix relations on symbols. Various
+;; changes are made to this so that MathML will like the results.
+
+;; Instructions:
+;; in macsyma, type mathml(<expression>); or mathml(<label>); or
+;; mathml(<expr-or-label>, <file-name>); In the case of a label,
+;; an equation-number will also be produced.
+;; in case a file-name is supplied, the output will be sent
+;; (perhaps appended) to that file.
+
+(macsyma-module mathml)
+
+#+franz
+($bothcases t) ;; allow alpha and Alpha to be different
+(declare-top
+ (special lop rop ccol $gcprint texport $labels $inchar
+ vaxima-main-dir
+ )
+ (*expr mathml-lbp mathml-rbp))
+
+;; top level command the result of converting the expression x.
+
+(defmspec $mathml(l) ;; mexplabel, and optional filename
+ ;;if filename supplied but 'nil' then return a string
+ (let ((args (cdr l)))
+ (cond ((and (cdr args) (null (cadr args)))
+ (let ((*standard-output* (make-string-output-stream)))
+ (apply 'mathml1 args)
+ (get-output-stream-string *standard-output*)
+ )
+ )
+ (t (apply 'mathml1 args)))))
+
+(defun mathml1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
+ (prog (mexp texport $gcprint ccol x y itsalabel tmpport)
+ ;; $gcprint = nil turns gc messages off
+ (setq ccol 1)
+ (cond ((null mexplabel)
+ (displa " No eqn given to MathML")
+ (return nil)))
+ ;; collect the file-name, if any, and open a port if needed
+ (setq texport (cond((null filename) *standard-output* ); t= output to terminal
+ (t
+ (open (string (stripdollar filename))
+ :direction :output
+ :if-exists :append
+ :if-does-not-exist :create))))
+ ;; go back and analyze the first arg more thoroughly now.
+ ;; do a normal evaluation of the expression in macsyma
+ (setq mexp (meval mexplabel))
+ (cond ((memq mexplabel $labels); leave it if it is a label
+ (setq mexplabel (concat "(" (stripdollar mexplabel) ")"))
+ (setq itsalabel t))
+ (t (setq mexplabel nil)));flush it otherwise
+
+ ;; maybe it is a function?
+ (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
+ (setq x ($verbify x))
+ (cond ((setq y (mget x 'mexpr))
+ (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'mmacro))
+ (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'aexpr))
+ (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
+ (cond ((and (null (atom mexp))
+ (memq (caar mexp) '(mdefine mdefmacro)))
+ (format texport "<pre>~%" )
+ (cond (mexplabel (format texport "~a " mexplabel)))
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ ((and
+ itsalabel ;; but is it a user-command-label?
+ (eq (getchar $inchar 2) (getchar mexplabel 2)))
+ ;; aha, this is a C-line: do the grinding:
+ (format texport "<pre>~%~a " mexplabel)
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ (t ; display the expression for MathML now:
+ (myprinc "<math xmlns='http://www.w3.org/1998/Math/MathML'> ")
+ (mapc #'myprinc
+ ;;initially the left and right contexts are
+ ;; empty lists, and there are implicit parens
+ ;; around the whole expression
+ (mathml mexp nil nil 'mparen 'mparen))
+ (cond (mexplabel
+ (format texport "<mspace width='verythickmathspace'/> <mtext>~a</mtext> " mexplabel)))
+ (format texport "</math>")))
+ (cond(filename(terpri texport); and drain port if not terminal
+ (close texport)))
+ (return mexplabel)))
+
+(defun mathml (x l r lop rop)
+ ;; x is the expression of interest; l is the list of strings to its
+ ;; left, r to its right. lop and rop are the operators on the left
+ ;; and right of x in the tree, and will determine if parens must
+ ;; be inserted
+ (setq x (nformat x))
+ (cond ((atom x) (mathml-atom x l r))
+ ((or (<= (mathml-lbp (caar x)) (mathml-rbp lop))
+ (> (mathml-lbp rop) (mathml-rbp (caar x))))
+ (mathml-paren x l r))
+ ;; special check needed because macsyma notates arrays peculiarly
+ ((memq 'array (cdar x)) (mathml-array x l r))
+ ;; dispatch for object-oriented mathml-ifiying
+ ((get (caar x) 'mathml) (funcall (get (caar x) 'mathml) x l r))
+ (t (mathml-function x l r nil))))
+
+(defun string-substitute (newstring oldchar x &aux matchpos)
+ (setq matchpos (position oldchar x))
+ (if (null matchpos) x
+ (concatenate 'string
+ (subseq x 0 matchpos)
+ newstring
+ (string-substitute newstring oldchar (subseq x (1+ matchpos))))))
+
+;;; NOTE that we try to include spaces after closing tags (e.g. "</mwhatever> ")
+;;; so that the line breaking algorithm in myprinc has some spaces where it
+;;; can choose to line break.
+
+;;; First we have the functions which are called directly by mathml and its
+;;; descendents
+
+(defun mathml-atom (x l r)
+ (append l
+ (list (cond ((numberp x) (mathmlnumformat x))
+ ((mstringp x) (string-left-trim '(#\&) x))
+ ((and (symbolp x) (get x 'mathmlword)))
+ (t (mathml-stripdollar x))))
+ r))
+
+(defun mathmlnumformat(atom)
+ (let (r firstpart exponent)
+ (cond ((integerp atom)
+ (strcat "<mn>" (format nil "~d" atom) "</mn> "))
+ (t
+ (setq r (explode atom))
+ (setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
+ (cond ((null exponent)
+ ;; it is not. go with it as given
+ (strcat "<mn>" (format nil "~s" atom) "</mn> "))
+ (t
+ (setq firstpart
+ (nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
+ (strcat
+ "<mrow><mn>"
+ (apply #'strcat firstpart)
+ "</mn><mo>×</mo> <msup><mn>10</mn><mn>"
+ (apply #'strcat (cdr exponent))
+ "</mn></msup> </mrow> ")
+ ))))))
+
+(defun mathml-stripdollar(sym)
+ (or (symbolp sym)
+ (return-from mathml-stripdollar sym))
+ (let* ((pname (string-left-trim '(#\$) (symbol-name sym)))
+ (l (length pname))
+ (begin-sub
+ (loop for i downfrom (1- l)
+ when (not (digit-char-p (aref pname i)))
+ do (return (1+ i)))))
+ (cond ((< begin-sub l) ;; need to do subscripting
+ (strcat "<msub><mi>"
+ (subseq pname 0 begin-sub)
+ "</mi> <mn>"
+ (subseq pname begin-sub l)
+ "</mn></msub> "))
+ (t ;; no subscripting needed
+ (strcat "<mi>" pname "</mi> ")))))
+
+(defun mathml-paren (x l r)
+ (mathml x (append l '("<mfenced separators=''>")) (cons "</mfenced> " r) 'mparen 'mparen))
+
+(defun mathml-array (x l r)
+ (let ((f))
+ (if (eq 'mqapply (caar x))
+ (setq f (cadr x)
+ x (cdr x)
+ l (mathml f (append l (list "<mfenced separators=','>"))
+ (list "</mfenced> ") 'mparen 'mparen))
+ (setq f (caar x)
+ l (mathml (mathmlword f) (append l '("<msub><mrow>")) nil lop 'mfunction)))
+ (setq
+ r (nconc (mathml-list (cdr x) nil (list "</mrow></msub> ") "<mo>,</mo>") r))
+ (nconc l (list "</mrow><mrow>") r )))
+
+;; set up a list , separated by symbols (, * ...) and then tack on the
+;; ending item (e.g. "]" or perhaps ")"
+(defun mathml-list (x l r sym)
+ (if (null x) r
+ (do ((nl))
+ ((null (cdr x))
+ (setq nl (nconc nl (mathml (car x) l r 'mparen 'mparen)))
+ nl)
+ (setq nl (nconc nl (mathml (car x) l (list sym) 'mparen 'mparen))
+ x (cdr x)
+ l nil))))
+
+;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
+;; operator
+(defun mathml-function (x l r op) op
+ (setq l (mathml (mathmlword (caar x)) l nil 'mparen 'mparen)
+ r (mathml (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
+ (nconc l r))
+
+;;; Now we have functions which are called via property lists
+
+(defun mathml-prefix (x l r)
+ (mathml (cadr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-infix (x l r)
+ ;; check for 2 args
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) l nil lop (caar x)))
+ (mathml (caddr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-postfix (x l r)
+ (mathml (cadr x) l (append (mathmlsym (caar x)) r) lop (caar x)))
+
+(defun mathml-nary (x l r)
+ (let* ((op (caar x)) (sym (mathmlsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
+ (cond ((null y) (mathml-function x l r t)) ; this should not happen
+ ((null (cdr y)) (mathml-function x l r t)) ; this should not happen, too
+ (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
+ ((null (cdr y)) (setq nl (nconc nl (mathml (car y) l r lop rop))) nl)
+ (setq nl (nconc nl (mathml (car y) l (list sym) lop rop))
+ y (cdr y)
+ l nil))))))
+
+(defun mathml-nofix (x l r) (mathml (caar x) l r (caar x) rop))
+
+(defun mathml-matchfix (x l r)
+ (setq l (append l (car (mathmlsym (caar x))))
+ ;; car of mathmlsym of a matchfix operator is the lead op
+ r (append (cdr (mathmlsym (caar x))) r)
+ ;; cdr is the trailing op
+ x (mathml-list (cdr x) nil r "<mo>,</mo>"))
+ (append l x))
+
+(defun mathmlsym (x) (or (get x 'mathmlsym) (get x 'strsym)(get x 'dissym)
+ (stripdollar x)))
+
+(defun mathmlword (x)(or (get x 'mathmlword) (stripdollar x)))
+
+(defprop bigfloat mathml-bigfloat mathml)
+
+(defun mathml-bigfloat (x l r) (declare (ignore l r)) (fpformat x))
+
+(defprop mprog "<mi>block</mi><mspace width='mediummathspace'/> " mathmlword)
+(defprop %erf "<mi>erf</mi> " mathmlword)
+(defprop $erf "<mi>erf</mi> " mathmlword) ;; etc for multicharacter names
+(defprop $true "<mi>true</mi> " mathmlword)
+(defprop $false "<mi>false</mi> " mathmlword)
+
+(defprop mprogn mathml-matchfix mathml) ;; mprogn is (<progstmnt>, ...)
+(defprop mprogn (("<mfenced separators=''>") "</mfenced> ") mathmlsym)
+
+(defprop mlist mathml-matchfix mathml)
+(defprop mlist (("<mfenced separators='' open='[' close=']'>")"</mfenced> ") mathmlsym)
+
+;;absolute value
+(defprop mabs mathml-matchfix mathml)
+(defprop mabs (("<mfenced separators='' open='|' close='|'>")"</mfenced> ") mathmlsym)
+
+(defprop mqapply mathml-mqapply mathml)
+
+(defun mathml-mqapply (x l r)
+ (setq l (mathml (cadr x) l (list "(" ) lop 'mfunction)
+ r (mathml-list (cddr x) nil (cons ")" r) "<mo>,</mo>"))
+ (append l r));; fixed 9/24/87 RJF
+
+(defprop $%i "<mi>ⅈ</mi> " mathmlword)
+(defprop $%pi "<mi>π</mi> " mathmlword)
+(defprop $%e "<mi>ⅇ</mi> " mathmlword)
+(defprop $inf "<mi>∞</mi> " mathmlword)
+(defprop $minf "<mi>-∞</mi> " mathmlword)
+(defprop %laplace "<mo>ℒ</mo>" mathmlword)
+(defprop $alpha "<mi>α</mi> " mathmlword)
+(defprop $beta "<mi>β</mi> " mathmlword)
+(defprop $gamma "<mi>γ</mi> " mathmlword)
+(defprop %gamma "<mi>Γ</mi> " mathmlword)
+(defprop $delta "<mi>δ</mi> " mathmlword)
+(defprop $epsilon "<mi>ε</mi> " mathmlword)
+(defprop $zeta "<mi>ζ</mi> " mathmlword)
+(defprop $eta "<mi>η</mi> " mathmlword)
+(defprop $theta "<mi>θ</mi> " mathmlword)
+(defprop $iota "<mi>ι</mi> " mathmlword)
+(defprop $kappa "<mi>κ</mi> " mathmlword)
+;(defprop $lambda "<mi>λ</mi> " mathmlword)
+(defprop $mu "<mi>μ</mi> " mathmlword)
+(defprop $nu "<mi>ν</mi> " mathmlword)
+(defprop $xi "<mi>ξ</mi> " mathmlword)
+(defprop $pi "<mi>π</mi> " mathmlword)
+(defprop $rho "<mi>ρ</mi> " mathmlword)
+(defprop $sigma "<mi>σ</mi> " mathmlword)
+(defprop $tau "<mi>τ</mi> " mathmlword)
+(defprop $upsilon "<mi>υ</mi> " mathmlword)
+(defprop $phi "<mi>φ</mi> " mathmlword)
+(defprop $chi "<mi>χ</mi> " mathmlword)
+(defprop $psi "<mi>ψ</mi> " mathmlword)
+(defprop $omega "<mi>ω</mi> " mathmlword)
+
+(defprop mquote mathml-prefix mathml)
+(defprop mquote ("<mo>'</mo>") mathmlsym)
+(defprop mquote 201. mathml-rbp)
+
+(defprop msetq mathml-infix mathml)
+(defprop msetq ("<mo>:</mo>") mathmlsym)
+(defprop msetq 180. mathml-rbp)
+(defprop msetq 20. mathml-rbp)
+
+(defprop mset mathml-infix mathml)
+(defprop mset ("<mo>::</mo>") mathmlsym)
+(defprop mset 180. mathml-lbp)
+(defprop mset 20. mathml-rbp)
+
+(defprop mdefine mathml-infix mathml)
+(defprop mdefine ("<mo>:=</mo>") mathmlsym)
+(defprop mdefine 180. mathml-lbp)
+(defprop mdefine 20. mathml-rbp)
+
+(defprop mdefmacro mathml-infix mathml)
+(defprop mdefmacro ("<mo>::=</mo>") mathmlsym)
+(defprop mdefmacro 180. mathml-lbp)
+(defprop mdefmacro 20. mathml-rbp)
+
+(defprop marrow mathml-infix mathml)
+(defprop marrow ("<mo>→</mo>") mathmlsym)
+(defprop marrow 25 mathml-lbp)
+(defprop marrow 25 mathml-rbp)
+
+(defprop mfactorial mathml-postfix mathml)
+(defprop mfactorial ("<mo>!</mo>") mathmlsym)
+(defprop mfactorial 160. mathml-lbp)
+
+(defprop mexpt mathml-mexpt mathml)
+(defprop mexpt 140. mathml-lbp)
+(defprop mexpt 139. mathml-rbp)
+
+(defprop %sum 110. mathml-rbp) ;; added by BLW, 1 Oct 2001
+(defprop %product 115. mathml-rbp) ;; added by BLW, 1 Oct 2001
+
+;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
+(defun mathml-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
+ (memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
+ (not (memq f '(%sum %product %derivative %integrate %at
+ %lsum %limit))) ;; 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 (mathml `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
+ (if (and (null (cdr bascdr))
+ (eq (get f 'mathml) 'mathml-prefix))
+ (setq r (mathml (car bascdr) nil r f 'mparen))
+ (setq r (mathml (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
+ (t nil))))) ; won't doit. fall through
+ (t (setq l (mathml (cadr x) (append l '("<msup><mrow>")) nil lop (caar x))
+ r (if (mmminusp (setq x (nformat (caddr x))))
+ ;; the change in base-line makes parens unnecessary
+ (if nc
+ (mathml (cadr x) '("</mrow> <mfenced separators='' open='<' close='>'> -")(cons "</mfenced></msup> " r) 'mparen 'mparen)
+ (mathml (cadr x) '("</mrow> <mfenced separators=''> -")(cons "</mfenced></msup> " r) 'mparen 'mparen))
+ (if nc
+ (mathml x (list "</mrow> <mfenced separators='' open='<' close='>'>")(cons "</mfenced></msup>" r) 'mparen 'mparen)
+ (if (and (numberp x) (< x 10))
+ (mathml x (list "</mrow> ")(cons "</msup> " r) 'mparen 'mparen)
+ (mathml x (list "</mrow> <mrow>")(cons "</mrow><mrow> " r) 'mparen 'mparen))
+ )))))
+ (append l r)))
+
+(defprop mncexpt mathml-mexpt mathml)
+
+(defprop mncexpt 135. mathml-lbp)
+(defprop mncexpt 134. mathml-rbp)
+
+(defprop mnctimes mathml-nary mathml)
+(defprop mnctimes "<mi>⋯</mi> " mathmlsym)
+(defprop mnctimes 110. mathml-lbp)
+(defprop mnctimes 109. mathml-rbp)
+
+(defprop mtimes mathml-nary mathml)
+(defprop mtimes "<mspace width='thinmathspace'/>" mathmlsym)
+(defprop mtimes 120. mathml-lbp)
+(defprop mtimes 120. mathml-rbp)
+
+(defprop %sqrt mathml-sqrt mathml)
+
+(defun mathml-sqrt(x l r)
+ ;; format as \\sqrt { } assuming implicit parens for sqr grouping
+ (mathml (cadr x) (append l '("<msqrt>")) (append '("</msqrt>") r) 'mparen 'mparen))
+
+;; macsyma doesn't know about cube (or nth) roots,
+;; but if it did, this is what it would look like.
+(defprop $cubrt mathml-cubrt mathml)
+
+(defun mathml-cubrt (x l r)
+ (mathml (cadr x) (append l '("<mroot><mrow>")) (append '("</mrow>3</mroot>") r) 'mparen 'mparen))
+
+(defprop mquotient mathml-mquotient mathml)
+(defprop mquotient ("<mo>/</mo>") mathmlsym)
+(defprop mquotient 122. mathml-lbp) ;;dunno about this
+(defprop mquotient 123. mathml-rbp)
+
+(defun mathml-mquotient (x l r)
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) (append l '("<mfrac><mrow>")) nil 'mparen 'mparen)
+ r (mathml (caddr x) (list "</mrow> <mrow>") (append '("</mrow></mfrac> ")r) 'mparen 'mparen))
+ (append l r))
+
+(defprop $matrix mathml-matrix mathml)
+
+(defun mathml-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
+ (append l `("<mfenced separators='' open='(' close=')'><mtable>")
+ (mapcan #'(lambda(y)
+ (mathml-list (cdr y) (list "<mtr><mtd>") (list "</mtd></mtr> ") "</mtd><mtd>"))
+ (cdr x))
+ '("</mtable></mfenced> ") r))
+
+;; macsyma sum or prod is over integer range, not low <= index <= high
+;; Mathml is lots more flexible .. but
+
+(defprop %sum mathml-sum mathml)
+(defprop %lsum mathml-lsum mathml)
+(defprop %product mathml-sum mathml)
+
+;; easily extended to union, intersect, otherops
+
+(defun mathml-lsum(x l r)
+ (let ((op (cond ((eq (caar x) '%lsum) "<mrow><munder><mo>∑</mo> <mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow></munder> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defun mathml-sum(x l r)
+ (let ((op (cond ((eq (caar x) '%sum) "<mrow><munderover><mo>∑</mo><mrow>")
+ ((eq (caar x) '%product) "<mrow><munderover><mo>∏</mo><mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
+ (toplim (mathml (car(cddddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow> <mrow>" ,@toplim "</mrow></munderover> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defprop %integrate mathml-int mathml)
+
+(defun mathml-int (x l r)
+ (let ((s1 (mathml (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
+ (var (mathml (caddr x) nil nil 'mparen rop))) ;; variable
+ (cond((= (length x) 3)
+ (append l `("<mrow><mo>∫</mo><mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi></mrow></mrow> ") r))
+ (t ;; presumably length 5
+ (let ((low (mathml (nth 3 x) nil nil 'mparen 'mparen))
+ ;; 1st item is 0
+ (hi (mathml (nth 4 x) nil nil 'mparen 'mparen)))
+ (append l `("<mrow><munderover><mo>∫</mo> <mrow>" ,@low "</mrow> <mrow>" ,@hi "</mrow> </munderover> <mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi> </mrow></mrow> ") r))))))
+
+(defprop %limit mathml-limit mathml)
+
+(defprop mrarr mathml-infix mathml)
+(defprop mrarr ("<mo>→</mo> ") mathmlsym)
+(defprop mrarr 80. mathml-lbp)
+(defprop mrarr 80. mathml-rbp)
+
+(defun mathml-limit(x l r) ;; ignoring direction, last optional arg to limit
+ (let ((s1 (mathml (second x) nil nil 'mparen rop));; limitfunction
+ (subfun ;; the thing underneath "limit"
+ (mathml `((mrarr simp) ,(third x) ,(fourth x)) nil nil 'mparen 'mparen)))
+ (append l `("<munder><mo>lim</mo><mrow>" ,@subfun "</mrow> </munder> <mrow>" ,@s1 "</mrow>") r)))
+
+(defprop %at mathml-at mathml)
+
+;; e.g. at(diff(f(x)),x=a)
+(defun mathml-at (x l r)
+ (let ((s1 (mathml (cadr x) nil nil lop rop))
+ (sub (mathml (caddr x) nil nil 'mparen 'mparen)))
+ (append l '("<msub><mfenced separators='' open='' close='|'>") s1 '("</mfenced> <mrow>") sub '("</mrow> </msub> ") r)))
+
+;;binomial coefficients
+
+(defprop %binomial mathml-choose mathml)
+
+(defun mathml-choose (x l r)
+ `(,@l
+ "<mfenced separators='' open='(' close=')'><mtable><mtr><mtd>"
+ ,@(mathml (cadr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> <mtr><mtd>"
+ ,@(mathml (caddr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> </mtable></mfenced> "
+ ,@r))
+
+
+(defprop rat mathml-rat mathml)
+(defprop rat 120. mathml-lbp)
+(defprop rat 121. mathml-rbp)
+(defun mathml-rat(x l r) (mathml-mquotient x l r))
+
+(defprop mplus mathml-mplus mathml)
+(defprop mplus 100. mathml-lbp)
+(defprop mplus 100. mathml-rbp)
+
+(defun mathml-mplus (x l r)
+ ;(declare (fixnum w))
+ (cond ((memq 'trunc (car x))(setq r (cons "<mo>+</mo><mtext>⋯</mtext> " r))))
+ (cond ((null (cddr x))
+ (if (null (cdr x))
+ (mathml-function x l r t)
+ (mathml (cadr x) (cons "<mo>+</mo>" l) r 'mplus rop)))
+ (t (setq l (mathml (cadr x) l nil lop 'mplus)
+ x (cddr x))
+ (do ((nl l) (dissym))
+ ((null (cdr x))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq r (mathml l dissym r 'mplus rop))
+ (append nl r))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq nl (append nl (mathml l dissym nil 'mplus 'mplus))
+ x (cdr x))))))
+
+(defprop mminus mathml-prefix mathml)
+(defprop mminus ("-") mathmlsym)
+(defprop mminus 100. mathml-rbp)
+(defprop mminus 100. mathml-lbp)
+
+(defprop min mathml-infix mathml)
+(defprop min ("<mo>∈</mo> ") mathmlsym)
+(defprop min 80. mathml-lbp)
+(defprop min 80. mathml-rbp)
+
+(defprop mequal mathml-infix mathml)
+(defprop mequal ("<mo>=</mo> ") mathmlsym)
+(defprop mequal 80. mathml-lbp)
+(defprop mequal 80. mathml-rbp)
+
+(defprop mnotequal mathml-infix mathml)
+(defprop mnotequal 80. mathml-lbp)
+(defprop mnotequal 80. mathml-rbp)
+
+(defprop mgreaterp mathml-infix mathml)
+(defprop mgreaterp ("<mo>></mo> ") mathmlsym)
+(defprop mgreaterp 80. mathml-lbp)
+(defprop mgreaterp 80. mathml-rbp)
+
+(defprop mgeqp mathml-infix mathml)
+(defprop mgeqp ("<mo>≥</mo> ") mathmlsym)
+(defprop mgeqp 80. mathml-lbp)
+(defprop mgeqp 80. mathml-rbp)
+
+(defprop mlessp mathml-infix mathml)
+(defprop mlessp ("<mo><</mo> ") mathmlsym)
+(defprop mlessp 80. mathml-lbp)
+(defprop mlessp 80. mathml-rbp)
+
+(defprop mleqp mathml-infix mathml)
+(defprop mleqp ("<mo>≤</mo> ") mathmlsym)
+(defprop mleqp 80. mathml-lbp)
+(defprop mleqp 80. mathml-rbp)
+
+(defprop mnot mathml-prefix mathml)
+(defprop mnot ("<mo>¬</mo> ") mathmlsym)
+(defprop mnot 70. mathml-rbp)
+
+(defprop mand mathml-nary mathml)
+(defprop mand ("<mo>∧</mo> ") mathmlsym)
+(defprop mand 60. mathml-lbp)
+(defprop mand 60. mathml-rbp)
+
+(defprop mor mathml-nary mathml)
+(defprop mor ("<mo>∨</mo> ") mathmlsym)
+
+;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
+;; etc
+
+(defun mathml-setup (x)
+ (let((a (car x))
+ (b (cadr x)))
+ (setf (get a 'mathml) 'mathml-prefix)
+ (setf (get a 'mathmlword) b) ;This means "sin" will always be roman
+ (setf (get a 'mathmlsym) (list b))
+ (setf (get a 'mathml-rbp) 130)))
+
+(mapc #'mathml-setup
+ '(
+ (%acos "<mi>arccos</mi> ")
+ (%asin "<mi>arcsin</mi> ")
+ (%atan "<mi>arctan</mi> ")
+ (%arg "<mi>arg</mi> ")
+ (%cos "<mi>cos</mi> ")
+ (%cosh "<mi>cosh</mi> ")
+ (%cot "<mi>cot</mi> ")
+ (%coth "<mi>coth</mi> ")
+ (%csc "<mi>cosec</mi> ")
+ (%deg "<mi>deg</mi> ")
+ (%determinant "<mi>det</mi> ")
+ (%dim "<mi>dim</mi> ")
+ (%exp "<mi>exp</mi> ")
+ (%gcd "<mi>gcd</mi> ")
+ (%hom "<mi>hom</mi> ")
+ (%inf "<mi>∞</mi> ")
+ (%ker "<mi>ker</mi> ")
+ (%lg "<mi>lg</mi> ")
+ ;;(%limit "<mi>lim</mi> ")
+ (%liminf "<mi>lim inf</mi> ")
+ (%limsup "<mi>lim sup</mi> ")
+ (%ln "<mi>ln</mi> ")
+ (%log "<mi>log</mi> ")
+ (%max "<mi>max</mi> ")
+ (%min "<mi>min</mi> ")
+ ; Latex's "Pr" ... ?
+ (%sec "<mi>sec</mi> ")
+ (%sech "<mi>sech</mi> ")
+ (%sin "<mi>sin</mi> ")
+ (%sinh "<mi>sinh</mi> ")
+ (%sup "<mi>sup</mi> ")
+ (%tan "<mi>tan</mi> ")
+ (%tanh "<mi>tanh</mi> ")
+ ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
+ ;(%laplace "{\\cal L}")
+ )) ;; etc
+
+(defprop mor mathml-nary mathml)
+(defprop mor 50. mathml-lbp)
+(defprop mor 50. mathml-rbp)
+
+(defprop mcond mathml-mcond mathml)
+(defprop mcond 25. mathml-lbp)
+(defprop mcond 25. mathml-rbp)
+
+(defprop %derivative mathml-derivative mathml)
+
+(defun mathml-derivative (x l r)
+ (mathml (mathml-d x "ⅆ") l r lop rop ))
+
+(defun mathml-d(x dsym) ;dsym should be "ⅆ" or "∂"
+ ;; 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '(mtimes)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mtimes)
+ ((mquotient) ,(simplifya numer nil) ,denom)
+ ,arg)))
+
+(defun mathml-mcond (x l r)
+ (append l
+ (mathml (cadr x) '("<mi>if</mi> <mspace width='mediummathspace'/>")
+ '("<mspace width='mediummathspace'/> <mi>then</mi><mspace width='mediummathspace'/> ") 'mparen 'mparen)
+ (if (eql (fifth x) '$false)
+ (mathml (caddr x) nil r 'mcond rop)
+ (append (mathml (caddr x) nil nil 'mparen 'mparen)
+ (mathml (fifth x) '("<mspace width='mediummathspace'/> <mi>else</mi><mspace width='mediummathspace'/> ") r 'mcond rop)))))
+
+(defprop mdo mathml-mdo mathml)
+(defprop mdo 30. mathml-lbp)
+(defprop mdo 30. mathml-rbp)
+(defprop mdoin mathml-mdoin mathml)
+(defprop mdoin 30. mathml-rbp)
+
+(defun mathml-lbp(x)(cond((get x 'mathml-lbp))(t(lbp x))))
+(defun mathml-rbp(x)(cond((get x 'mathml-rbp))(t(lbp x))))
+
+;; these aren't quite right
+
+(defun mathml-mdo (x l r)
+ (mathml-list (mathmlmdo x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathml-mdoin (x l r)
+ (mathml-list (mathmlmdoin x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathmlmdo (x)
+ (nconc (cond ((second x) `("<mi>for</mi> " ,(second x))))
+ (cond ((equal 1 (third x)) nil)
+ ((third x) `("<mi>from</mi> " ,(third x))))
+ (cond ((equal 1 (fourth x)) nil)
+ ((fourth x) `("<mi>step</mi> " ,(fourth x)))
+ ((fifth x) `("<mi>next</mi> " ,(fifth x))))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+(defun mathmlmdoin (x)
+ (nconc `("<mi>for</mi>" ,(second x) "<mi>in</mi> " ,(third x))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+;; Undone and trickier:
+;; Maybe do some special hacking for standard notations for
+;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
diff --git a/stack/2018030500/maxima/multiply_blank.lisp b/stack/2018030500/maxima/multiply_blank.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8299d076a99df596824a75e72ac37c9cff2759dc
--- /dev/null
+++ b/stack/2018030500/maxima/multiply_blank.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\, ") texsym)
diff --git a/stack/2018030500/maxima/multiply_cross.lisp b/stack/2018030500/maxima/multiply_cross.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ec0052c83f44c454a238de0e579d79121ebf2f3b
--- /dev/null
+++ b/stack/2018030500/maxima/multiply_cross.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\times ") texsym)
diff --git a/stack/2018030500/maxima/multiply_dot.lisp b/stack/2018030500/maxima/multiply_dot.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fb7cb69891f68486972dd35d406fe5a2b79fe1f8
--- /dev/null
+++ b/stack/2018030500/maxima/multiply_dot.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\cdot ") texsym)
diff --git a/stack/2018030500/maxima/noun_arith.lisp b/stack/2018030500/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3ffda4a9b0b67068f7d0b8ba9291b3b35212fbf1
--- /dev/null
+++ b/stack/2018030500/maxima/noun_arith.lisp
@@ -0,0 +1,47 @@
+;; 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)
+
+;; Chris Sangwin 3 Feb 2016.
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ and }}\\, ") texsym)
+(defprop $nounand 69. tex-lbp)
+(defprop $nounand 69. tex-rbp)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ or }}\\, ") texsym)
+(defprop $nounor 70. tex-lbp)
+(defprop $nounor 70. tex-rbp)
+
+;; Chris Sangwin 29 Sept 2017.
+
+(defprop mnot tex-prefix tex)
+(defprop mnot ("{\\rm not}") texsym)
\ No newline at end of file
diff --git a/stack/2018030500/maxima/rtest_assessment_simpboth.mac b/stack/2018030500/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bc02f607f7cb9219dbadde904a5e70c875460a14
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/rtest_assessment_simpfalse.mac b/stack/2018030500/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/rtest_assessment_simptrue.mac b/stack/2018030500/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6f71fbf308f39067a419f103f2f6e41a93f1d725
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/rtest_elementary.mac b/stack/2018030500/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/rtest_experimental.mac b/stack/2018030500/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/stack/2018030500/maxima/rtest_inequalities.mac b/stack/2018030500/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2498d27574c6e7dc113cb932b6f23b37ce4a1214
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/rtest_intervals.mac b/stack/2018030500/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2e72d77091c1fb56eba98f1d12cbbc7a692ced3b
--- /dev/null
+++ b/stack/2018030500/maxima/rtest_intervals.mac
@@ -0,0 +1,62 @@
+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+x^2+1/(x+1));
+realset(x,%union(oo(-1,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)))$
+
+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;
\ No newline at end of file
diff --git a/stack/2018030500/maxima/sandbox.wxm b/stack/2018030500/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..8162b8c7b20469febe2605e9c84020b5446d960a
--- /dev/null
+++ b/stack/2018030500/maxima/sandbox.wxm
@@ -0,0 +1,67 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 15.08.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. Download the files from github, either using git or as a zip file.
+2. Place the files somewhere they can be read, and edit the line velow to give the location.
+ E.g. Place the files in C:\files\stack
+3. Specify a directory for temporary working files, e.g. 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 ] */
+/* In MS platforms use the forward slash as a directory seperator. No trailing slash. */
+stacklocation:"C:/files/stack"$
+stacktmplocation:"C:/tmp"$
+
+/****************************************************
+ There should be no need to edit below this line.
+
+ These commands add the location to Maxima's search path.
+*/
+file_search_maxima:append( [sconcat(stacklocation, "/question/type/stack/stack/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/question/type/stack/stack/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:38.3,
+ MAXIMA_PLATFORM:"win",
+ 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.41.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 ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2018030500/maxima/stackmaxima.mac b/stack/2018030500/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..776c5b2c28caf5f90ee74eb1daffe398d33dd518
--- /dev/null
+++ b/stack/2018030500/maxima/stackmaxima.mac
@@ -0,0 +1,2784 @@
+/* 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(rand_seed) := 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,
+ 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),
+
+ /*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(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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(1000);
+
+alias(int,integrate); /* Allows integrate to be called with int() */
+alias(cosec,csc); /* 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. */
+
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+load ("functs");
+
+/* 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");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+alias(arccos, acos); /* At the request of the OU, 4 Feb 2013. */
+alias(arcsin, asin);
+alias(arctan, atan);
+
+load("mathml.lisp");
+
+make_complexJ(OPT_COMPLEXJ) := block(
+ if OPT_COMPLEXJ = "i" then
+ (i:%i,load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "j" then
+ (%j:%i,j:%i,load("complexj.lisp"))
+ else if OPT_COMPLEXJ = "symi" then
+ (load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "symj" then
+ (load("complexj.lisp"))
+ else true
+);
+
+/* Choose the symbol for the multiplication sign. */
+make_multsgn(OPT_MULTSGN) := block(
+ if OPT_MULTSGN = "cross" then load("multiply_cross.lisp"),
+ if OPT_MULTSGN = "dot" then load("multiply_dot.lisp"),
+ if OPT_MULTSGN = "blank" then load("multiply_blank.lisp")
+);
+
+/* Options for cos^(-1), acos or arccos. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then load("cos-1.lisp"),
+ if OPT_ACOS = "arccos" then load("arccos.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))
+)$
+
+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 (
+ print("rand_selection error: first argument must be a list."),
+ return([])
+ ),
+ if not(integerp(n)) then (
+ print("rand_selection error: second argument must be an integer."),
+ return([])
+ ),
+ if is(n>length(ex)) then (
+ print("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 three 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(ex[2]-ex[1]), simp)),
+ if not(integerp(ex[3])) then error("rand_range expects its first argument to be an integer."),
+ if is(length(ex)=3) then return(ev(ex[1]+ex[3]*rand(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: forth 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 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: forth 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)))))
+)$
+
+/* ********************************** */
+/* 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"}), 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 = "d" then block(ld: "\\[", rd:"\\]"),
+ expstr: tex(expru, false),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* MathML display */
+ if OPT_OUTPUT = "MathML" then
+ str: mathml(expr, false),
+ /* 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
+ 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)))),
+ /* Strip out empty plus operators, which cause problems in display with simp:false. */
+ /* This is not, strictly speaking, a subscript issue, but we don't want another recursive call. */
+ if is(safe_op(ex)="+") and is(length(args(ex))=1) then return(stack_disp_sub_script(first(args(ex)))),
+ 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, "_"),
+ s: maplist(parse_string, 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)))
+)$
+
+/* ********************************** */
+/* 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)
+)$
+
+detexdecorate(ex) := block([argsex],
+ if mapatom(ex) then return(ex),
+ argsex:args(ex),
+ if op(ex) = texdecorate then return(detexdecorate(argsex[2])),
+ if op(ex) = "/" then return(detexdecorate(argsex[1])/detexdecorate(argsex[2])),
+ map(detexdecorate, ex)
+)$
+
+/* Assume all non-numeric atoms are to be displayed in bold. */
+texboldatoms(ex) := block(
+ if numberp(ex) then return(ex),
+ if atom(ex) then return(texdecorate("\\bf", ex)),
+ if arrayp(ex) then return(arraymake(op(ex), maplist(texboldatoms, args(ex)))),
+ apply(op(ex), maplist(texboldatoms, args(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 (print("\\mbox{ERROR: argument to stack_matrix_disp must be a matrix.} "), return("")),
+ if not(stringp(lmxchar)) then (print("\\mbox{ERROR: stack_matrix_disp requires lmxchar to be a string. }"), return("")),
+ parens: sublist(stack_matrix_pairs, lambda([ex], is(first(ex)=lmxchar))),
+ if emptyp(parens) then (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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) then return(ex),
+ ex2: unary_minus_traverse(ex),
+ return(unary_minus_pull(ex2))
+)$
+
+/* ********************************************************************* */
+/* 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(
+ ex: detexcolor(ex),
+ ex: detexdecorate(ex),
+ ex: make_displaydpvalue(ex),
+ ex: make_displayscivalue(ex),
+ ex: opsubst("*", stackunits, ex),
+ return(string(ex))
+)$
+
+/* ********************************** */
+/* 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: concat(fb, "stack_trans('", key, "'", exprs, "); !NEWLINE!"),
+ return(str)
+)$
+
+/* Separate notes with puncutation, to enable clearer reading
+ and the possibility to split them. */
+StackAddNote(exnote, 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)]$
+
+/* ********************************************************* */
+/* Turns answertest output to a STACK return object string */
+/* */
+/* ex[1] = validity should be true/false */
+/* ex[2] = result should be true/false, */
+/* ex[3] = feedback, a string */
+/* ex[4] = answernote, is for teacher stats */
+/* */
+/* ********************************************************* */
+
+StackReturn(ex) := block([str],
+ if not(listp(ex)) then
+ (print("StackReturn failed: argument not a list: "), print(string(ex)), return("")),
+ if length(ex)#4 then
+ (print("StackReturn failed: argument wrong length: "), print(string(ex)), return("")),
+ print(" ], valid = [ "),
+ if ex[1] then print(1) else print(0),
+ print(" ], answernote = [ "),
+ print(ex[3]),
+ print(" ], feedback = [ "),
+ print(ex[4]),
+ return(ex[2])
+)$
+
+/* 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 */
+/* ******************************************* */
+
+stack_validate(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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. */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms. */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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"))),
+ /* Check if the student's answer is the same type as the Teacher's. */
+ SameType:ATSameTypefun(expr, TAns),
+ if SameType[2]#true then print(SameType[4]),
+ /* Now display the result. */
+ simp: false,
+ expr: detexcolor(expr),
+ expr: detexdecorate(expr),
+ return(expr)
+)$
+
+/* Validate an expression without type checking. Floats and mathematical errors only. */
+stack_validate_typeless(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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 */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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)
+)$
+
+/* These functions convert all variables in an expression to products of single letter variable names. */
+stack_singlevar_make_helper(ex) := block([s],
+ s: maplist(eval_string, charlist(string(ex))),
+ apply("*", s)
+)$
+
+stack_singlevar_make(ex) := block([vars, subs],
+ vars: sublist(listofvars(ex), lambda([ex], if slength(string(ex))>1 then true else false)),
+ if emptyp(vars) then return(ex),
+ vars:maplist(lambda([ex], ex=stack_singlevar_make_helper(ex)), vars),
+ /* We only need to use associtativity of "*", not "+", but we have to do it over the whole expression. */
+ STACK_assoc(sublis(vars, ex), ["*"])
+)$
+
+/* 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],
+ 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(logbase, ex)) then
+ ex:ev(ex, logbase=logbasesimp),
+ lvs: listofvars(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ if length(lvs)>1 then
+ (print(concat("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /*********************/
+ /* 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ /*******************/
+ /* 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
+ (print(concat("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /********************************************/
+ /* 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='", alttext, "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class=\"stack_plot\">", ufn, "</div>"),
+ if OPT_OUTPUT#"MathML" then
+ 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(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"))]),
+
+ SA:sort(float(listify(SA))),
+ SB:sort(float(listify(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([Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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 not(integerp(nsf) and integerp(asf)) then
+ (print("TEST_FAILED"),return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* SA should be only a number. */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ SA:SAA[1],
+ if (not(floatnump(SA)) and not(integerp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* 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 not(is(sign(SA)=sign(SB))) 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.
+ This changes 1.5 -> 2.0 (2.s.f). */
+ SB:significantfigures(SB, nsf),
+ /* Puts Teacher's answer 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,
+ 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)
+)$
+
+/* ********************************** */
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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, eg 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([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 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 an equation? */
+ /* Don't use logic_edgep(SB) here, as this include "true" and "false". A teacher should use all/none if they mean equations. */
+ if (equationp(SB) or SB = all or SB = none) then
+ /* But the student can also use true/false here. Note the concious asymetry. */
+ if (equationp(SA) or logic_edgep(SA)) then
+ return(ATEquation(SA, SB))
+ else if equationp(SB) and not equationp(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, "+-"))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ /* Are we dealing with an inequality? */
+ if inequalityp(SB) then
+ if inequalityp(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)),
+ /* 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)
+)$
+
+/* 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]),
+ SA1:args(SA), SAd1:second(SA1),
+ SB1:args(SB), SBd1:second(SB1),
+ /* 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]),
+ FeedBack:StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i")),
+ if (SAr#SBr) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), FeedBack]),
+ if (SAc#SBc) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), FeedBack]),
+ FeedBack:"",
+ /* 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, str, SAl, SBl, ZM],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Get sizes of matrices */
+ SAl:cardinality(SA),
+ SBl:cardinality(SB),
+ FeedBack:StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i")),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ SA:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "d")),
+ return([true, false, StackAddNote("","ATSet_wrongentries"), 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,"+-")=1), simp) then SA:pm_replace(SA),
+ if ev(is(count_op(SB,"+-")=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, "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, "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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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 */
+ 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"),""]),
+
+ /* 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 not is(ev(setify(listofvars(S1)),simp)=ev(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, ""]) else
+ 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,""]) else
+ if op(SB) = "+" then return(irred_Q(SB, SO)) else
+ 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),
+ /* 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: StackReturn */
+/* 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:StackAddFeedback("",""), 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****************************** */
+/* requires: Student Answer */
+/* List: [Teachers Answer, variable with which partial */
+/* fraction occurs, whether Formative Feedback is required */
+/* returns: StackReturn */
+/* Cases: */
+/* Returns True iff algebraic equivalence with TList[1] */
+/* and Division is the Top Operator. */
+/* False if Division not the top operator */
+/* False if different Variables are used */
+/* True(0) otherwise */
+/* ******************************************************************** */
+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 op(SAA) = "/" then block(
+ if (freeof("/", num(SAA)) and freeof("/", denom(SAA))) then block(
+ rawmk:true,
+ ansnote:"ATSingleFrac_true")
+ else 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])
+)$
+
+
+/*****************************************************************/
+/* Useful function for Partial Fractions */
+/*****************************************************************/
+
+divthru(q) :=
+ if (not atom(q) and part(q,0)="/")
+ then
+ block([num, den, div, quo, rem],
+ num:part(q, 1),
+ den:part(q, 2),
+ div:divide(num, den) ,
+ quo:div[1],
+ rem:div[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(SBL[2], "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 */
+ 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])="^" 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"), ""]),
+
+ 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:"",
+ debug:false,
+ 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
+);
+
+/********************************************************************/
+/* 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:true, 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"),""]),
+
+ /* 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 algebraic_equivalence(diff(SA,v),int(SB,v)) 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)
+ )$
+
+/* ****************************************************** */
+/* */
+/* 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("")
+)$
+
+/* 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:2018030500$
diff --git a/stack/2018030500/maxima/stackreporting.mac b/stack/2018030500/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93
--- /dev/null
+++ b/stack/2018030500/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(
+ print("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/2018030500/maxima/stacktex.lisp b/stack/2018030500/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5e971bc03d25547fb1ea5ea93d2c0b0b05caf209
--- /dev/null
+++ b/stack/2018030500/maxima/stacktex.lisp
@@ -0,0 +1,349 @@
+;; 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)
+
+(defun tex-texdecorate (x l r)
+ (let
+ ((front (append '("{")
+ (list (stripdollar (cadr x)))
+ '("")))
+ (back (append '("{")
+ (tex (caddr x) nil nil 'mparen 'mparen)
+ '("}}"))))
+ (append l front back r)))
+
+(defprop $texdecorate tex-texdecorate 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '($blankmult)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom)
+ ))
+
+
+(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 $+-) :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))))
+
+
diff --git a/stack/2018030500/maxima/stacktex40.lisp b/stack/2018030500/maxima/stacktex40.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2f688179b2c7d0573e3db8a3caef343746f7fbae
--- /dev/null
+++ b/stack/2018030500/maxima/stacktex40.lisp
@@ -0,0 +1,91 @@
+;; 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 $+-) :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)))
+
+;; *************************************************************************************************
+;; 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) (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/2018030500/maxima/stackunits.mac b/stack/2018030500/maxima/stackunits.mac
new file mode 100644
index 0000000000000000000000000000000000000000..eb01d04b72e678f5887fd43fba609845a29ce870
--- /dev/null
+++ b/stack/2018030500/maxima/stackunits.mac
@@ -0,0 +1,570 @@
+/* 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}"],
+*/
+
+/* Add rules to the simplifier to deal with stackunits. */
+matchdeclare(STACKNUM1, all, STACKNUM2, all, STACKUNITS1, all, STACKUNITS2, all, STACKNUM, numberp)$
+matchdeclare(STACKANY, all)$
+tellsimpafter(STACKNUM*stackunits(STACKNUM1,STACKUNITS1), stackunits(STACKNUM*STACKNUM1, STACKUNITS1));
+tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)^STACKNUM, stackunits(STACKNUM1^STACKNUM, STACKUNITS1^STACKNUM));
+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)+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 is 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)="+-") 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 a product we are return what we are given. */
+ if 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(
+ print("fracdisp argument to stack_validate_units 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),
+
+ /* 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)="+-")) 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),
+ expr:detexdecorate(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 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. */
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "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, SAU1, SBU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ SAA:errcatch(ev(SA, simp, nouns)),
+ if (is_simp(SAA = [STACKERROR]) or is_simp(SAA = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is_simp(SBB = [STACKERROR]) or is_simp(SBB = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is_simp(SOO = [STACKERROR]) or is_simp(SOO = [])) 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 (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU)),
+
+ /* 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, ol])),
+ if (numtest = "SigFigs") then
+ ret1: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret1: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret1: ATNumRelative(SAU1, SBU1, ol)
+ 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]]),
+
+ /* 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),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(SB),
+ if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU)),
+ /* Check the accuracy again, now we have converted. */
+ SAU1:ev(float(stack_units_nums(SAU)), simp),
+ SBU1:ev(float(stack_units_nums(SBU)), simp),
+ if (numtest = "SigFigs") then
+ ret2: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret2: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret2: ATNumRelative(SAU1, SBU1, ol)
+ 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/2018030500/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2018030500/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d4e798fd0706ced74f70dd61ce6c9a3d2f943b85
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/unittests_load.mac b/stack/2018030500/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..072158a1c3ce7b06181b68fe7c37e507718f471b
--- /dev/null
+++ b/stack/2018030500/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/2018030500/maxima/utils.mac b/stack/2018030500/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..940f0fadcf9004fd103dfc8713dfb71d86ad3f35
--- /dev/null
+++ b/stack/2018030500/maxima/utils.mac
@@ -0,0 +1,115 @@
+/* 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)
+)$
+
+
+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/2018080600/maxima/arccos.lisp b/stack/2018080600/maxima/arccos.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..963ff6b45f83923546f7163cc973266c91102e7e
--- /dev/null
+++ b/stack/2018080600/maxima/arccos.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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/2018080600/maxima/assessment.mac b/stack/2018080600/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..7a8e81bc3fe52334d9e9cf7f9e6e25b4a5d38bbd
--- /dev/null
+++ b/stack/2018080600/maxima/assessment.mac
@@ -0,0 +1,2076 @@
+/* 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(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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],
+ 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)$
+
+/* ********************************** */
+/* 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)
+)$
+
+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) 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);
+
+/* Add in support for logarithms to an arbirary base. */
+lg([ex]) := block(
+ if length(ex) = 1 then return(logbase(first(ex), 10)),
+ if length(ex) = 2 then return(logbase(first(ex), second(ex))),
+ error("STACK function 'lg' must have one or two arguments only.")
+)$
+
+logbasetex(ex) := block([n, b],
+ [n, b]:args(ex),
+ oldsimp:simp,
+ return(concat("\\log_{", stack_disp_strip_dollars(tex(b, false)), "}\\left(", stack_disp_strip_dollars(tex(n, false)), "\\right)"))
+)$
+texput(logbase, logbasetex);
+
+/* Use of radcan to give canonical form. */
+logbasesimp(n,b) := radcan(log(n)/log(b));
+
+/* 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), logbase=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)
+)$
+
+/* 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)), logbase=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 not(real_numberp(x)) then error("sigfigsfun(x,n,d) requires a real number 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), logbase=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([a]) := block([simp:false, x, ex, ex2, ex3, exn],
+ 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), logbase=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),
+ return(ex3)
+ ),
+ 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.
+*/
+
+
+/* ********************************** */
+/* 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/9/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.
+*/
+algebraic_equivalence(SA, SB) :=
+ block([keepfloat, trigexpand, logexpand, ex, vi],
+ /* Reject obviously different expressions. These can be very time consuming in the tests below. */
+ /* The code below is actually making the situation worse: needs reconsidering. */
+ if numerical_not_alg_equiv(SA, SB) then return(false),
+ trigexpand:true,
+ 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 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(logbase, SA)) then
+ SA:ev(SA, logbase=logbasesimp),
+ if not(freeof(logbase, SB)) then
+ SB:ev(SB, logbase=logbasesimp),
+ /* Try not to expand out: pure numbers. */
+ ex:errcatch(ev(SA-SB, simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating collectterms threw an error."), return(false)),
+ ex:ex[1],
+ ex:errcatch(ev(radcan_num(ex), simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating radcan_num an error."), return(false)),
+ 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 (print("algebraic_equivalence: factoring the difference of two expressions threw an error."), return(false)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ ex:errcatch(ratsimp(ex)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 */
+ 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],
+ /* 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 is(pval = []) then (print("STACK: ignore previous error. (p1)"), return(false)),
+ if abs(first(pval)) > 1/10000 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)),
+ sz:errcatch(ev(abs(float(first(p1)-first(p2))), 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);
+
+verb_arith(ex) := block(
+ 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(
+ 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))))),
+ apply(op(ex), maplist(flatten_recurse_nouns, args(ex)))
+)$
+
+/* 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, ex1n, ex2n, ret],
+ oldsimp:simp,
+ simp:false,
+ ex1n:noun_arith(ex1),
+ ex2n:noun_arith(ex2),
+ simp:true,
+ ex1n:ev(flatten_recurse_nouns(ex1n), simp),
+ ex2n:ev(flatten_recurse_nouns(ex2n), simp),
+ if ex1n=ex2n then ret:true else ret:false,
+ simp:oldsimp,
+ ret
+)$
+
+/* An answer test in the context of commutative+associative addition and multiplication. */
+ATEqualComAss(sa, sb) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB],
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]),
+
+ /* We need 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)$
+
+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) = "and" then return(true),
+ if safe_op(ex) = "or" then return(true),
+ if safe_op(ex) = "not" then return(true),
+ if op_usedp(ex, "+-") 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", "and", "or", "%and", "%or", "not", "%not", "+-", "<", ">", "<=", ">=", "=", "[", "{"],
+ 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:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", 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)
+)$
+
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ return(rex)
+)$
+
+/****************************************************************/
+/* Define noun versions of other functions */
+/****************************************************************/
+
+nounint([ex]):=apply(nounify(integrate), ex)$
+noundiff([ex]):=apply(nounify(diff), ex)$
+
+/* ********************************** */
+/* Add in a +- operator */
+/* ********************************** */
+
+/* We have to define +- to be both a prefix and an nary operator in this order. */
+prefix("+-");
+nary("+-", 100);
+
+displaypmtex(ex):=block([al, a1, a2],
+ al:args(ex),
+ if is(length(al)=1) then
+ return(sconcat(" \\pm ", tex1(first(al)))),
+ a1:tex1(first(al)),
+ a2:tex1(second(al)),
+ sconcat("{", a1, " \\pm ", a2, "}")
+ );
+texput("+-", 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, "+-")=1), simp) then return(opsubst("+", "+-", ex) nounor opsubst("-", "+-", 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 ev(argfac=factor(argfac), simp) then
+ return(true),
+ if mapatom(argfac) then
+ return(false),
+ /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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 (
+ print("comp_square: var should be an atom but not a number. "),
+ return(ex)
+ ),
+ ex:ratsimp(expand(ex)),
+ if not(polynomialp(ex, [var])) then (
+ print("comp_square: ex should be a polynomial in var. "),
+ return(ex)
+ ),
+ if hipow(ex, var)#2 then (
+ print("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 */
+/****************************/
+
+/*
+ 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(EQUIVCHARREAL, "\\color{green}{\\Leftrightarrow}\\, \\color{blue}{(\\mathbb{R})}");
+texput(CHECKMARK, "\\color{green}{\\checkmark}");
+texput(IMPLIESCHAR, "\\color{red}{\\Rightarrow}");
+texput(IMPLIEDCHAR, "\\color{red}{\\Leftarrow}");
+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);
+
+/* 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 (print("stack_disp_arg expects to receive a list."), return(false)),
+ 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,"+-")=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, logbase=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))
+ )
+ )
+ ),
+
+ /* Can we work out what has gone wrong? */
+ if (debug) then print("** Checking for common mistakes **"),
+ if (debug) then print(SA),
+ if (debug) then print(SB),
+ 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,
+
+ if (debug) and not(malrulecont) then print("** Not actually checking for common mistakes ... **"),
+
+ /* 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([SAD, SBD, var, ATres],
+ /* (C0) Calculus operations. */
+ var:last(sort(listofvars(SA))),
+ SAD:ev(SA, nouns, simp),
+ SAD:ev(diff(SAD,var), simp),
+ SBD:ev(SB, nouns, simp),
+ SBD:ev(diff(SBD,var), simp),
+ 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 ")
+ )
+ )
+ )
+ ),
+
+ /* 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),
+
+ 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))
+ )
+ )
+ )
+ ),
+ 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],
+
+ 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(
+ ex2:ev(solve(ex2, sort(listofvars(ex2)))), simp),
+ if assume_real then
+ ex2:ev(sublist(ex2, lambda([m], freeof(%i, m))), simp),
+ if not(emptyp(ex2)) then (ex2:map(lambda([ex], apply("%and", ex)), ex2), ex:apply("%or", ex2))
+ ),
+ 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
+ res:unknown
+ 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 (
+ print("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))
+)$
+
+/* 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],
+
+ /* 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],
+
+ /* 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,
+
+ /* 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/2018080600/maxima/assessment.texi b/stack/2018080600/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/complexi.lisp b/stack/2018080600/maxima/complexi.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8be0972956d17463313be86ea1bd76f1b9552cbb
--- /dev/null
+++ b/stack/2018080600/maxima/complexi.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{i}" texword)
+
+(defprop $%i "<mi>i</mi> " mathmlword)
diff --git a/stack/2018080600/maxima/complexj.lisp b/stack/2018080600/maxima/complexj.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1fdfd5b91a8993b84fc72fd9f39114151c8dd4ce
--- /dev/null
+++ b/stack/2018080600/maxima/complexj.lisp
@@ -0,0 +1,10 @@
+;; Customize Maxima's TEX() function.
+;; Make %i print at a "j"
+;; Chris Sangwin 19 August Jan 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 $%i "\\mathrm{j}" texword)
+
+(defprop $%i "<mi>j</mi> " mathmlword)
diff --git a/stack/2018080600/maxima/cos-1.lisp b/stack/2018080600/maxima/cos-1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7cdb2e2d0c69d196c7ae93ea9c9f2740ece76b59
--- /dev/null
+++ b/stack/2018080600/maxima/cos-1.lisp
@@ -0,0 +1,51 @@
+(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". Hmmm.
+ ; 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 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/2018080600/maxima/elementary.mac b/stack/2018080600/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..77cb7ddc99b1fb2410361c1cefb654b41cc414ed
--- /dev/null
+++ b/stack/2018080600/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 print("ERROR: 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/2018080600/maxima/expandfeedback.mac b/stack/2018080600/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/experimental.mac b/stack/2018080600/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..98afe06e41c2d99210e1ca9301fcd43e1b447811
--- /dev/null
+++ b/stack/2018080600/maxima/experimental.mac
@@ -0,0 +1,175 @@
+/* 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))));
+
+/****************************************************************/
+/* Inequality functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.2 July 2013 */
+/* */
+/****************************************************************/
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* 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 (print("STACK exception: node_no expects its first argument to be a list."), return(false)),
+ if not(integerp(num)) then (print("STACK exception: node_no expects its second argument to be an integer."), return(false)),
+ if is(length(prt)<num) then (print("STACK exception: node_no expects its second argument to less than the length of the first."), return(false)),
+ /* 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 (print("STACK exception: traverse_prt expects its argument to be a list."), return(false)),
+ if not(alllistp(equationp,inputs)) then (print("STACK exception: traverse_prt expects its argument to be a list of equations."), return(false)),
+ /* 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, <chris@sangwin.com> */
+/* 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/2018080600/maxima/inequalities.mac b/stack/2018080600/maxima/inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..ff1fb41618b225e1099705c0fdabd6a2642730f5
--- /dev/null
+++ b/stack/2018080600/maxima/inequalities.mac
@@ -0,0 +1,305 @@
+/* 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 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 print("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/2018080600/maxima/intervals.mac b/stack/2018080600/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..4b27906196fe4bfc757ac8be0040cc859b697021
--- /dev/null
+++ b/stack/2018080600/maxima/intervals.mac
@@ -0,0 +1,1027 @@
+/* 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 intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.2 June 2017 */
+/* */
+/********************************************************************/
+
+/* 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
+ );
+*/
+
+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(Complement(b), simp),
+ if 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)],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(false),
+ 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 setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(intervalp, args(ex))),
+ 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=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 atom(ex) then return(false),
+ if setp(ex) and ex={} then return(true),
+ if save_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)
+)$
+
+SimpleUnion(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 setp(A) then
+ (
+ if 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 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 setp(A) or atom(B) or 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:SimpleUnion( 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)
+ )
+ )
+ )
+ )
+ ),
+ if safe_op(Ans)="[" then Ans:apply(%union, Ans),
+ Ans
+ );
+
+
+/* Finds the intersection of two "simple" sets: */
+SimpleIntersect(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 Ans:{} elseif
+ atom(B) then Ans:{} elseif
+ setp(A) then
+ (
+ if setp(B) then
+ (
+ return(intersect(A,B))
+ )
+ else
+ (
+ 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:{}
+ )
+ )
+ elseif setp(B) then
+ (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do
+ (if inintervalp(Aset[i],A) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans:setAns ) else Ans:{}
+ ),
+ if ( not atom(A) and not atom(B) ) then
+ (
+ Args1:args(A),
+ Args2:args(B),
+
+ if (not atom(A) and not(op(A)=set) and not atom(B) and not(op(B)=set) ) 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:{},
+ 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
+ );
+
+SimpDisjointp(A,B) := if SimpleIntersect(A,B)={} then true else false;
+
+/* Given a *list* of disjoint intervals, returns the same intervals but in ascending order: */
+SortUnion(X) :=
+ block ( [A:X, Ans:[], x, n, i],
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ if ( first( A[i] ) < first( x ) ) then x:A[i],
+ i:i+1
+ ),
+ Ans:append( Ans, [x] ),
+ A:delete( x, A, 1 ),
+ n:n-1
+ ),
+ Ans
+ );
+
+/* Given a union of disjoint intervals, checks whether any intervals are connected, and if so, joins them up and returns the ammended union: */
+ConnectIntervals(X):=
+ block ( [Ans, n, x, y, i:1],
+
+ if not(op(X)=%union) then error("ConnectIntervals requires a %union of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ if last( Ans[i] ) >= first( Ans[i+1] ) then
+ (
+ x:SimpleUnion( Ans[i], Ans[i+1] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[i+1], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ n:n-1,
+ i:i-1
+ )
+ ),
+ 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: */
+TidyUnion(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),
+
+ if (not (op(X)=%union or op(X)="[") ) then Ans:X
+ else
+ (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<n+1 do
+ (
+ if ( setp(A[i]) ) then
+ (
+ setpart:union( setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ )
+ else if ( trivialintervalp(A[i]) ) then
+ (
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ ),
+ i:i+1
+ ),
+ A:SortUnion(A),
+ if is(length(A)>1) then
+ A:ConnectIntervals(apply(%union, A)),
+ if length(setpart)>0 then A:append( args(A), [setpart] ),
+ if is(length(A)=1) then
+ A:first(A),
+ Ans:A
+ ),
+ Ans
+ )$
+
+/* Finds the union of any two sets: */
+Union(X, Y) :=
+ block ( [A, B, Ans:[], Joined:[], sets:{}, add, temp, x, y, m, n, k, i:1, j:1, f:1],
+ if atom(X) then Ans:Y
+ elseif atom(Y) then Ans:X
+ else
+ (
+
+ A:X,
+ if op(X)=%union then A:args(X),
+ B:Y,
+ if op(Y)=%union then B:args(Y),
+
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleUnion(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:Union(A,B) )
+ else
+ (
+ while i<(m+1)do
+ (
+ if op( A[i] ) = set then
+ (
+ sets:SimpleUnion( sets , A[i] ),
+ A:delete( A[i] , A , 1 ),
+ i:i-1,
+ m:m-1
+ ),
+ i:i+1
+ ),
+ i:1,
+ while j<(n+1)do
+ (
+ if op( B[j] ) = set then
+ (
+ sets:SimpleUnion( sets , B[j] ),
+ B:delete( B[j] , B , 1 ),
+ j:j-1,
+ n:n-1
+ ),
+ j:j+1
+ ),
+ j:1,
+ temp:Ans,
+
+ Joined:append(A,B),
+ Joined:JoinedUnion(Joined),
+ temp:append(temp,Joined),
+
+ if length(sets)>0 then
+ (
+ sets:listify(sets),
+ m:length(temp),
+ n:length(sets),
+ while j<(n+1) do
+ (
+ while i<(m+1) do
+ (
+ x:first( temp[i] ),
+ y:last( temp[i] ),
+ if inintervalp( sets[j], temp[i] ) then
+ (
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ )
+ elseif ( sets[j]=x or sets[j]=y ) then
+ (
+ temp[i]:Union( temp[i], { sets[j] } ) ,
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ ),
+ i:i+1
+ ),
+ i:1,
+ j:j+1
+ ),
+ j:1,
+ if length(sets)>0 then
+ (
+ sets:setify(sets),
+ temp:cons(sets,temp)
+ )
+ ),
+ if length(temp)=1 then temp:temp[1],
+ Ans:temp
+ )
+ ),
+ Ans:TidyUnion(Ans)
+ ),
+
+ Ans
+ );
+
+/* When given a union of intervals, this function simplifies the union by joining up any connected intervals: */
+JoinedUnion(X) :=
+ block ( [A, nextA:[], disjoint:[], temp, Ans:[], n, i, j, alldisjoint:false, Joined:[] ],
+
+ A:X,
+ if op(A)=%union then A:args(A),
+ while alldisjoint = false do
+ (
+ alldisjoint:true,
+ n:length(A),
+ disjoint:[],
+ i:1,
+ while i<n+1 do
+ (
+ disjoint: append(disjoint, [true] ),
+ i:i+1
+ ),
+ i:1,
+ while i<n do
+ (
+ j:i+1,
+ while j<n+1 do
+ (
+ if ( SimpDisjointp( A[i], A[j] ) ) then
+ (
+ if disjoint[j] = true then
+ (
+ nextA:delete( A[j], nextA, 1),
+ nextA:append(nextA, [ A[j] ] )
+ )
+ )
+ else (
+ nextA:delete( A[i], nextA, 1),
+ nextA:delete( A[j], nextA, 1),
+ temp:SimpleUnion( A[i], A[j] ),
+ if ( not op(temp) = "[" ) then temp:[temp],
+ nextA:append(nextA, temp ),
+ disjoint[i]:false,
+ disjoint[j]:false,
+ alldisjoint:false
+ ),
+ j:j+1
+ ),
+ if disjoint[i] = true then
+ (
+ nextA:delete( A[i], nextA, 1 ),
+ nextA:append(nextA, [ A[i] ] )
+ ),
+ i:i+1
+ ),
+ if alldisjoint = false then A:nextA,
+ nextA:[]
+ ),
+ Ans:A,
+ Ans
+ );
+
+Intersection(X,Y) :=
+ block ([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if is(A=all) then return(B)
+ elseif is(B=all) then return(A)
+ elseif atom(A) then Ans:{}
+ elseif atom(B) then Ans:{}
+ else
+ (
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleIntersect(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:SimpleIntersect(A,B) )
+ else
+ (
+ while i<m+1 do
+ (
+ while j<n+1 do
+ (
+ temp:SimpleIntersect( A[i], B[j] ),
+ if not atom(temp) then
+ (
+ Ans:append( Ans, [temp] )
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ )
+ ),
+ if (not atom(Ans)) and op(Ans) = "[" then
+ (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ )
+ ),
+ Ans:TidyUnion(Ans),
+ Ans
+ );
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+ListIntersect(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:Intersection(Ans,A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+OrderPoints(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:TidyUnion(A),
+ if op( last(A) ) = set 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
+ );
+
+
+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( Ans:oo(-inf,inf) ),
+ if not (op(A) = "[" or op(A)=%union) then
+ (
+ if op(A)=set then Ans:SetComplement(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:OrderPoints(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(ListIntersect(maplist(lambda([ex2], TidyUnion(Complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ else if listp(Ans) then
+ Ans:apply(%union, Ans)
+ ),
+
+ Ans
+ );
+
+SetComplement(X):=
+ block ( [A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("SetComplement 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("%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), realsetp), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realsetp(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, realsetp), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realsetp(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([TidyUnion(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([ListIntersect(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: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)="logbase" 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(realsetp(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:ListIntersect(ex2),
+ ex2
+)$
diff --git a/stack/2018080600/maxima/mathml.lisp b/stack/2018080600/maxima/mathml.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7671dad91e31b7c9b9caf64c27e3891e2d73e4c0
--- /dev/null
+++ b/stack/2018080600/maxima/mathml.lisp
@@ -0,0 +1,762 @@
+(in-package "MAXIMA")
+;; MathML-printing
+;; Created by David Drysdale (DMD), December 2002/January 2003
+;;
+;; closely based on the original TeX conversion code in mactex.lisp,
+;; for which the following credits apply:
+;; (c) copyright 1987, Richard J. Fateman
+;; small corrections and additions: Andrey Grozin, 2001
+;; additional additions: Judah Milgram (JM), September 2001
+;; additional corrections: Barton Willis (BLW), October 2001
+
+;; Usage: mathml(d8,"/tmp/foo.xml"); mathml(d10,"/tmp/foo.xml"); ..
+;; to append lines d8 and d10 to the mathml file. If given only
+;; one argument the result goes to standard output.
+
+;; Method:
+
+;; Producing MathML from a macsyma internal expression is done by
+;; a reversal of the parsing process. Fundamentally, a
+;; traversal of the expression tree is produced by the program,
+;; with appropriate substitutions and recognition of the
+;; infix / prefix / postfix / matchfix relations on symbols. Various
+;; changes are made to this so that MathML will like the results.
+
+;; Instructions:
+;; in macsyma, type mathml(<expression>); or mathml(<label>); or
+;; mathml(<expr-or-label>, <file-name>); In the case of a label,
+;; an equation-number will also be produced.
+;; in case a file-name is supplied, the output will be sent
+;; (perhaps appended) to that file.
+
+(macsyma-module mathml)
+
+#+franz
+($bothcases t) ;; allow alpha and Alpha to be different
+(declare-top
+ (special lop rop ccol $gcprint texport $labels $inchar
+ vaxima-main-dir
+ )
+ (*expr mathml-lbp mathml-rbp))
+
+;; top level command the result of converting the expression x.
+
+(defmspec $mathml(l) ;; mexplabel, and optional filename
+ ;;if filename supplied but 'nil' then return a string
+ (let ((args (cdr l)))
+ (cond ((and (cdr args) (null (cadr args)))
+ (let ((*standard-output* (make-string-output-stream)))
+ (apply 'mathml1 args)
+ (get-output-stream-string *standard-output*)
+ )
+ )
+ (t (apply 'mathml1 args)))))
+
+(defun mathml1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
+ (prog (mexp texport $gcprint ccol x y itsalabel tmpport)
+ ;; $gcprint = nil turns gc messages off
+ (setq ccol 1)
+ (cond ((null mexplabel)
+ (displa " No eqn given to MathML")
+ (return nil)))
+ ;; collect the file-name, if any, and open a port if needed
+ (setq texport (cond((null filename) *standard-output* ); t= output to terminal
+ (t
+ (open (string (stripdollar filename))
+ :direction :output
+ :if-exists :append
+ :if-does-not-exist :create))))
+ ;; go back and analyze the first arg more thoroughly now.
+ ;; do a normal evaluation of the expression in macsyma
+ (setq mexp (meval mexplabel))
+ (cond ((memq mexplabel $labels); leave it if it is a label
+ (setq mexplabel (concat "(" (stripdollar mexplabel) ")"))
+ (setq itsalabel t))
+ (t (setq mexplabel nil)));flush it otherwise
+
+ ;; maybe it is a function?
+ (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
+ (setq x ($verbify x))
+ (cond ((setq y (mget x 'mexpr))
+ (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'mmacro))
+ (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
+ ((setq y (mget x 'aexpr))
+ (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
+ (cond ((and (null (atom mexp))
+ (memq (caar mexp) '(mdefine mdefmacro)))
+ (format texport "<pre>~%" )
+ (cond (mexplabel (format texport "~a " mexplabel)))
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ ((and
+ itsalabel ;; but is it a user-command-label?
+ (eq (getchar $inchar 2) (getchar mexplabel 2)))
+ ;; aha, this is a C-line: do the grinding:
+ (format texport "<pre>~%~a " mexplabel)
+ ;; need to get rid of "<" signs
+ (setq tmpport (make-string-output-stream))
+ (mgrind mexp tmpport)
+ (close tmpport)
+ (format texport "~a"
+ (string-substitute "<" #\< (get-output-stream-string tmpport)))
+ (format texport ";~%</pre>"))
+
+ (t ; display the expression for MathML now:
+ (myprinc "<math xmlns='http://www.w3.org/1998/Math/MathML'> ")
+ (mapc #'myprinc
+ ;;initially the left and right contexts are
+ ;; empty lists, and there are implicit parens
+ ;; around the whole expression
+ (mathml mexp nil nil 'mparen 'mparen))
+ (cond (mexplabel
+ (format texport "<mspace width='verythickmathspace'/> <mtext>~a</mtext> " mexplabel)))
+ (format texport "</math>")))
+ (cond(filename(terpri texport); and drain port if not terminal
+ (close texport)))
+ (return mexplabel)))
+
+(defun mathml (x l r lop rop)
+ ;; x is the expression of interest; l is the list of strings to its
+ ;; left, r to its right. lop and rop are the operators on the left
+ ;; and right of x in the tree, and will determine if parens must
+ ;; be inserted
+ (setq x (nformat x))
+ (cond ((atom x) (mathml-atom x l r))
+ ((or (<= (mathml-lbp (caar x)) (mathml-rbp lop))
+ (> (mathml-lbp rop) (mathml-rbp (caar x))))
+ (mathml-paren x l r))
+ ;; special check needed because macsyma notates arrays peculiarly
+ ((memq 'array (cdar x)) (mathml-array x l r))
+ ;; dispatch for object-oriented mathml-ifiying
+ ((get (caar x) 'mathml) (funcall (get (caar x) 'mathml) x l r))
+ (t (mathml-function x l r nil))))
+
+(defun string-substitute (newstring oldchar x &aux matchpos)
+ (setq matchpos (position oldchar x))
+ (if (null matchpos) x
+ (concatenate 'string
+ (subseq x 0 matchpos)
+ newstring
+ (string-substitute newstring oldchar (subseq x (1+ matchpos))))))
+
+;;; NOTE that we try to include spaces after closing tags (e.g. "</mwhatever> ")
+;;; so that the line breaking algorithm in myprinc has some spaces where it
+;;; can choose to line break.
+
+;;; First we have the functions which are called directly by mathml and its
+;;; descendents
+
+(defun mathml-atom (x l r)
+ (append l
+ (list (cond ((numberp x) (mathmlnumformat x))
+ ((mstringp x) (string-left-trim '(#\&) x))
+ ((and (symbolp x) (get x 'mathmlword)))
+ (t (mathml-stripdollar x))))
+ r))
+
+(defun mathmlnumformat(atom)
+ (let (r firstpart exponent)
+ (cond ((integerp atom)
+ (strcat "<mn>" (format nil "~d" atom) "</mn> "))
+ (t
+ (setq r (explode atom))
+ (setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
+ (cond ((null exponent)
+ ;; it is not. go with it as given
+ (strcat "<mn>" (format nil "~s" atom) "</mn> "))
+ (t
+ (setq firstpart
+ (nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
+ (strcat
+ "<mrow><mn>"
+ (apply #'strcat firstpart)
+ "</mn><mo>×</mo> <msup><mn>10</mn><mn>"
+ (apply #'strcat (cdr exponent))
+ "</mn></msup> </mrow> ")
+ ))))))
+
+(defun mathml-stripdollar(sym)
+ (or (symbolp sym)
+ (return-from mathml-stripdollar sym))
+ (let* ((pname (string-left-trim '(#\$) (symbol-name sym)))
+ (l (length pname))
+ (begin-sub
+ (loop for i downfrom (1- l)
+ when (not (digit-char-p (aref pname i)))
+ do (return (1+ i)))))
+ (cond ((< begin-sub l) ;; need to do subscripting
+ (strcat "<msub><mi>"
+ (subseq pname 0 begin-sub)
+ "</mi> <mn>"
+ (subseq pname begin-sub l)
+ "</mn></msub> "))
+ (t ;; no subscripting needed
+ (strcat "<mi>" pname "</mi> ")))))
+
+(defun mathml-paren (x l r)
+ (mathml x (append l '("<mfenced separators=''>")) (cons "</mfenced> " r) 'mparen 'mparen))
+
+(defun mathml-array (x l r)
+ (let ((f))
+ (if (eq 'mqapply (caar x))
+ (setq f (cadr x)
+ x (cdr x)
+ l (mathml f (append l (list "<mfenced separators=','>"))
+ (list "</mfenced> ") 'mparen 'mparen))
+ (setq f (caar x)
+ l (mathml (mathmlword f) (append l '("<msub><mrow>")) nil lop 'mfunction)))
+ (setq
+ r (nconc (mathml-list (cdr x) nil (list "</mrow></msub> ") "<mo>,</mo>") r))
+ (nconc l (list "</mrow><mrow>") r )))
+
+;; set up a list , separated by symbols (, * ...) and then tack on the
+;; ending item (e.g. "]" or perhaps ")"
+(defun mathml-list (x l r sym)
+ (if (null x) r
+ (do ((nl))
+ ((null (cdr x))
+ (setq nl (nconc nl (mathml (car x) l r 'mparen 'mparen)))
+ nl)
+ (setq nl (nconc nl (mathml (car x) l (list sym) 'mparen 'mparen))
+ x (cdr x)
+ l nil))))
+
+;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
+;; operator
+(defun mathml-function (x l r op) op
+ (setq l (mathml (mathmlword (caar x)) l nil 'mparen 'mparen)
+ r (mathml (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
+ (nconc l r))
+
+;;; Now we have functions which are called via property lists
+
+(defun mathml-prefix (x l r)
+ (mathml (cadr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-infix (x l r)
+ ;; check for 2 args
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) l nil lop (caar x)))
+ (mathml (caddr x) (append l (mathmlsym (caar x))) r (caar x) rop))
+
+(defun mathml-postfix (x l r)
+ (mathml (cadr x) l (append (mathmlsym (caar x)) r) lop (caar x)))
+
+(defun mathml-nary (x l r)
+ (let* ((op (caar x)) (sym (mathmlsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
+ (cond ((null y) (mathml-function x l r t)) ; this should not happen
+ ((null (cdr y)) (mathml-function x l r t)) ; this should not happen, too
+ (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
+ ((null (cdr y)) (setq nl (nconc nl (mathml (car y) l r lop rop))) nl)
+ (setq nl (nconc nl (mathml (car y) l (list sym) lop rop))
+ y (cdr y)
+ l nil))))))
+
+(defun mathml-nofix (x l r) (mathml (caar x) l r (caar x) rop))
+
+(defun mathml-matchfix (x l r)
+ (setq l (append l (car (mathmlsym (caar x))))
+ ;; car of mathmlsym of a matchfix operator is the lead op
+ r (append (cdr (mathmlsym (caar x))) r)
+ ;; cdr is the trailing op
+ x (mathml-list (cdr x) nil r "<mo>,</mo>"))
+ (append l x))
+
+(defun mathmlsym (x) (or (get x 'mathmlsym) (get x 'strsym)(get x 'dissym)
+ (stripdollar x)))
+
+(defun mathmlword (x)(or (get x 'mathmlword) (stripdollar x)))
+
+(defprop bigfloat mathml-bigfloat mathml)
+
+(defun mathml-bigfloat (x l r) (declare (ignore l r)) (fpformat x))
+
+(defprop mprog "<mi>block</mi><mspace width='mediummathspace'/> " mathmlword)
+(defprop %erf "<mi>erf</mi> " mathmlword)
+(defprop $erf "<mi>erf</mi> " mathmlword) ;; etc for multicharacter names
+(defprop $true "<mi>true</mi> " mathmlword)
+(defprop $false "<mi>false</mi> " mathmlword)
+
+(defprop mprogn mathml-matchfix mathml) ;; mprogn is (<progstmnt>, ...)
+(defprop mprogn (("<mfenced separators=''>") "</mfenced> ") mathmlsym)
+
+(defprop mlist mathml-matchfix mathml)
+(defprop mlist (("<mfenced separators='' open='[' close=']'>")"</mfenced> ") mathmlsym)
+
+;;absolute value
+(defprop mabs mathml-matchfix mathml)
+(defprop mabs (("<mfenced separators='' open='|' close='|'>")"</mfenced> ") mathmlsym)
+
+(defprop mqapply mathml-mqapply mathml)
+
+(defun mathml-mqapply (x l r)
+ (setq l (mathml (cadr x) l (list "(" ) lop 'mfunction)
+ r (mathml-list (cddr x) nil (cons ")" r) "<mo>,</mo>"))
+ (append l r));; fixed 9/24/87 RJF
+
+(defprop $%i "<mi>ⅈ</mi> " mathmlword)
+(defprop $%pi "<mi>π</mi> " mathmlword)
+(defprop $%e "<mi>ⅇ</mi> " mathmlword)
+(defprop $inf "<mi>∞</mi> " mathmlword)
+(defprop $minf "<mi>-∞</mi> " mathmlword)
+(defprop %laplace "<mo>ℒ</mo>" mathmlword)
+(defprop $alpha "<mi>α</mi> " mathmlword)
+(defprop $beta "<mi>β</mi> " mathmlword)
+(defprop $gamma "<mi>γ</mi> " mathmlword)
+(defprop %gamma "<mi>Γ</mi> " mathmlword)
+(defprop $delta "<mi>δ</mi> " mathmlword)
+(defprop $epsilon "<mi>ε</mi> " mathmlword)
+(defprop $zeta "<mi>ζ</mi> " mathmlword)
+(defprop $eta "<mi>η</mi> " mathmlword)
+(defprop $theta "<mi>θ</mi> " mathmlword)
+(defprop $iota "<mi>ι</mi> " mathmlword)
+(defprop $kappa "<mi>κ</mi> " mathmlword)
+;(defprop $lambda "<mi>λ</mi> " mathmlword)
+(defprop $mu "<mi>μ</mi> " mathmlword)
+(defprop $nu "<mi>ν</mi> " mathmlword)
+(defprop $xi "<mi>ξ</mi> " mathmlword)
+(defprop $pi "<mi>π</mi> " mathmlword)
+(defprop $rho "<mi>ρ</mi> " mathmlword)
+(defprop $sigma "<mi>σ</mi> " mathmlword)
+(defprop $tau "<mi>τ</mi> " mathmlword)
+(defprop $upsilon "<mi>υ</mi> " mathmlword)
+(defprop $phi "<mi>φ</mi> " mathmlword)
+(defprop $chi "<mi>χ</mi> " mathmlword)
+(defprop $psi "<mi>ψ</mi> " mathmlword)
+(defprop $omega "<mi>ω</mi> " mathmlword)
+
+(defprop mquote mathml-prefix mathml)
+(defprop mquote ("<mo>'</mo>") mathmlsym)
+(defprop mquote 201. mathml-rbp)
+
+(defprop msetq mathml-infix mathml)
+(defprop msetq ("<mo>:</mo>") mathmlsym)
+(defprop msetq 180. mathml-rbp)
+(defprop msetq 20. mathml-rbp)
+
+(defprop mset mathml-infix mathml)
+(defprop mset ("<mo>::</mo>") mathmlsym)
+(defprop mset 180. mathml-lbp)
+(defprop mset 20. mathml-rbp)
+
+(defprop mdefine mathml-infix mathml)
+(defprop mdefine ("<mo>:=</mo>") mathmlsym)
+(defprop mdefine 180. mathml-lbp)
+(defprop mdefine 20. mathml-rbp)
+
+(defprop mdefmacro mathml-infix mathml)
+(defprop mdefmacro ("<mo>::=</mo>") mathmlsym)
+(defprop mdefmacro 180. mathml-lbp)
+(defprop mdefmacro 20. mathml-rbp)
+
+(defprop marrow mathml-infix mathml)
+(defprop marrow ("<mo>→</mo>") mathmlsym)
+(defprop marrow 25 mathml-lbp)
+(defprop marrow 25 mathml-rbp)
+
+(defprop mfactorial mathml-postfix mathml)
+(defprop mfactorial ("<mo>!</mo>") mathmlsym)
+(defprop mfactorial 160. mathml-lbp)
+
+(defprop mexpt mathml-mexpt mathml)
+(defprop mexpt 140. mathml-lbp)
+(defprop mexpt 139. mathml-rbp)
+
+(defprop %sum 110. mathml-rbp) ;; added by BLW, 1 Oct 2001
+(defprop %product 115. mathml-rbp) ;; added by BLW, 1 Oct 2001
+
+;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
+(defun mathml-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
+ (memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
+ (not (memq f '(%sum %product %derivative %integrate %at
+ %lsum %limit))) ;; 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 (mathml `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
+ (if (and (null (cdr bascdr))
+ (eq (get f 'mathml) 'mathml-prefix))
+ (setq r (mathml (car bascdr) nil r f 'mparen))
+ (setq r (mathml (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
+ (t nil))))) ; won't doit. fall through
+ (t (setq l (mathml (cadr x) (append l '("<msup><mrow>")) nil lop (caar x))
+ r (if (mmminusp (setq x (nformat (caddr x))))
+ ;; the change in base-line makes parens unnecessary
+ (if nc
+ (mathml (cadr x) '("</mrow> <mfenced separators='' open='<' close='>'> -")(cons "</mfenced></msup> " r) 'mparen 'mparen)
+ (mathml (cadr x) '("</mrow> <mfenced separators=''> -")(cons "</mfenced></msup> " r) 'mparen 'mparen))
+ (if nc
+ (mathml x (list "</mrow> <mfenced separators='' open='<' close='>'>")(cons "</mfenced></msup>" r) 'mparen 'mparen)
+ (if (and (numberp x) (< x 10))
+ (mathml x (list "</mrow> ")(cons "</msup> " r) 'mparen 'mparen)
+ (mathml x (list "</mrow> <mrow>")(cons "</mrow><mrow> " r) 'mparen 'mparen))
+ )))))
+ (append l r)))
+
+(defprop mncexpt mathml-mexpt mathml)
+
+(defprop mncexpt 135. mathml-lbp)
+(defprop mncexpt 134. mathml-rbp)
+
+(defprop mnctimes mathml-nary mathml)
+(defprop mnctimes "<mi>⋯</mi> " mathmlsym)
+(defprop mnctimes 110. mathml-lbp)
+(defprop mnctimes 109. mathml-rbp)
+
+(defprop mtimes mathml-nary mathml)
+(defprop mtimes "<mspace width='thinmathspace'/>" mathmlsym)
+(defprop mtimes 120. mathml-lbp)
+(defprop mtimes 120. mathml-rbp)
+
+(defprop %sqrt mathml-sqrt mathml)
+
+(defun mathml-sqrt(x l r)
+ ;; format as \\sqrt { } assuming implicit parens for sqr grouping
+ (mathml (cadr x) (append l '("<msqrt>")) (append '("</msqrt>") r) 'mparen 'mparen))
+
+;; macsyma doesn't know about cube (or nth) roots,
+;; but if it did, this is what it would look like.
+(defprop $cubrt mathml-cubrt mathml)
+
+(defun mathml-cubrt (x l r)
+ (mathml (cadr x) (append l '("<mroot><mrow>")) (append '("</mrow>3</mroot>") r) 'mparen 'mparen))
+
+(defprop mquotient mathml-mquotient mathml)
+(defprop mquotient ("<mo>/</mo>") mathmlsym)
+(defprop mquotient 122. mathml-lbp) ;;dunno about this
+(defprop mquotient 123. mathml-rbp)
+
+(defun mathml-mquotient (x l r)
+ (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
+ (setq l (mathml (cadr x) (append l '("<mfrac><mrow>")) nil 'mparen 'mparen)
+ r (mathml (caddr x) (list "</mrow> <mrow>") (append '("</mrow></mfrac> ")r) 'mparen 'mparen))
+ (append l r))
+
+(defprop $matrix mathml-matrix mathml)
+
+(defun mathml-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
+ (append l `("<mfenced separators='' open='(' close=')'><mtable>")
+ (mapcan #'(lambda(y)
+ (mathml-list (cdr y) (list "<mtr><mtd>") (list "</mtd></mtr> ") "</mtd><mtd>"))
+ (cdr x))
+ '("</mtable></mfenced> ") r))
+
+;; macsyma sum or prod is over integer range, not low <= index <= high
+;; Mathml is lots more flexible .. but
+
+(defprop %sum mathml-sum mathml)
+(defprop %lsum mathml-lsum mathml)
+(defprop %product mathml-sum mathml)
+
+;; easily extended to union, intersect, otherops
+
+(defun mathml-lsum(x l r)
+ (let ((op (cond ((eq (caar x) '%lsum) "<mrow><munder><mo>∑</mo> <mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow></munder> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defun mathml-sum(x l r)
+ (let ((op (cond ((eq (caar x) '%sum) "<mrow><munderover><mo>∑</mo><mrow>")
+ ((eq (caar x) '%product) "<mrow><munderover><mo>∏</mo><mrow>")
+ ;; extend here
+ ))
+ ;; gotta be one of those above
+ (s1 (mathml (cadr x) nil nil 'mparen rop));; summand
+ (index ;; "index = lowerlimit"
+ (mathml `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
+ (toplim (mathml (car(cddddr x)) nil nil 'mparen 'mparen)))
+ (append l `( ,op ,@index "</mrow> <mrow>" ,@toplim "</mrow></munderover> <mrow>" ,@s1 "</mrow></mrow> ") r)))
+
+(defprop %integrate mathml-int mathml)
+
+(defun mathml-int (x l r)
+ (let ((s1 (mathml (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
+ (var (mathml (caddr x) nil nil 'mparen rop))) ;; variable
+ (cond((= (length x) 3)
+ (append l `("<mrow><mo>∫</mo><mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi></mrow></mrow> ") r))
+ (t ;; presumably length 5
+ (let ((low (mathml (nth 3 x) nil nil 'mparen 'mparen))
+ ;; 1st item is 0
+ (hi (mathml (nth 4 x) nil nil 'mparen 'mparen)))
+ (append l `("<mrow><munderover><mo>∫</mo> <mrow>" ,@low "</mrow> <mrow>" ,@hi "</mrow> </munderover> <mrow>" ,@s1 "</mrow> <mspace width='mediummathspace'/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi> </mrow></mrow> ") r))))))
+
+(defprop %limit mathml-limit mathml)
+
+(defprop mrarr mathml-infix mathml)
+(defprop mrarr ("<mo>→</mo> ") mathmlsym)
+(defprop mrarr 80. mathml-lbp)
+(defprop mrarr 80. mathml-rbp)
+
+(defun mathml-limit(x l r) ;; ignoring direction, last optional arg to limit
+ (let ((s1 (mathml (second x) nil nil 'mparen rop));; limitfunction
+ (subfun ;; the thing underneath "limit"
+ (mathml `((mrarr simp) ,(third x) ,(fourth x)) nil nil 'mparen 'mparen)))
+ (append l `("<munder><mo>lim</mo><mrow>" ,@subfun "</mrow> </munder> <mrow>" ,@s1 "</mrow>") r)))
+
+(defprop %at mathml-at mathml)
+
+;; e.g. at(diff(f(x)),x=a)
+(defun mathml-at (x l r)
+ (let ((s1 (mathml (cadr x) nil nil lop rop))
+ (sub (mathml (caddr x) nil nil 'mparen 'mparen)))
+ (append l '("<msub><mfenced separators='' open='' close='|'>") s1 '("</mfenced> <mrow>") sub '("</mrow> </msub> ") r)))
+
+;;binomial coefficients
+
+(defprop %binomial mathml-choose mathml)
+
+(defun mathml-choose (x l r)
+ `(,@l
+ "<mfenced separators='' open='(' close=')'><mtable><mtr><mtd>"
+ ,@(mathml (cadr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> <mtr><mtd>"
+ ,@(mathml (caddr x) nil nil 'mparen 'mparen)
+ "</mtd></mtr> </mtable></mfenced> "
+ ,@r))
+
+
+(defprop rat mathml-rat mathml)
+(defprop rat 120. mathml-lbp)
+(defprop rat 121. mathml-rbp)
+(defun mathml-rat(x l r) (mathml-mquotient x l r))
+
+(defprop mplus mathml-mplus mathml)
+(defprop mplus 100. mathml-lbp)
+(defprop mplus 100. mathml-rbp)
+
+(defun mathml-mplus (x l r)
+ ;(declare (fixnum w))
+ (cond ((memq 'trunc (car x))(setq r (cons "<mo>+</mo><mtext>⋯</mtext> " r))))
+ (cond ((null (cddr x))
+ (if (null (cdr x))
+ (mathml-function x l r t)
+ (mathml (cadr x) (cons "<mo>+</mo>" l) r 'mplus rop)))
+ (t (setq l (mathml (cadr x) l nil lop 'mplus)
+ x (cddr x))
+ (do ((nl l) (dissym))
+ ((null (cdr x))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq r (mathml l dissym r 'mplus rop))
+ (append nl r))
+ (if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
+ (setq l (car x) dissym (list "<mo>+</mo> ")))
+ (setq nl (append nl (mathml l dissym nil 'mplus 'mplus))
+ x (cdr x))))))
+
+(defprop mminus mathml-prefix mathml)
+(defprop mminus ("-") mathmlsym)
+(defprop mminus 100. mathml-rbp)
+(defprop mminus 100. mathml-lbp)
+
+(defprop min mathml-infix mathml)
+(defprop min ("<mo>∈</mo> ") mathmlsym)
+(defprop min 80. mathml-lbp)
+(defprop min 80. mathml-rbp)
+
+(defprop mequal mathml-infix mathml)
+(defprop mequal ("<mo>=</mo> ") mathmlsym)
+(defprop mequal 80. mathml-lbp)
+(defprop mequal 80. mathml-rbp)
+
+(defprop mnotequal mathml-infix mathml)
+(defprop mnotequal 80. mathml-lbp)
+(defprop mnotequal 80. mathml-rbp)
+
+(defprop mgreaterp mathml-infix mathml)
+(defprop mgreaterp ("<mo>></mo> ") mathmlsym)
+(defprop mgreaterp 80. mathml-lbp)
+(defprop mgreaterp 80. mathml-rbp)
+
+(defprop mgeqp mathml-infix mathml)
+(defprop mgeqp ("<mo>≥</mo> ") mathmlsym)
+(defprop mgeqp 80. mathml-lbp)
+(defprop mgeqp 80. mathml-rbp)
+
+(defprop mlessp mathml-infix mathml)
+(defprop mlessp ("<mo><</mo> ") mathmlsym)
+(defprop mlessp 80. mathml-lbp)
+(defprop mlessp 80. mathml-rbp)
+
+(defprop mleqp mathml-infix mathml)
+(defprop mleqp ("<mo>≤</mo> ") mathmlsym)
+(defprop mleqp 80. mathml-lbp)
+(defprop mleqp 80. mathml-rbp)
+
+(defprop mnot mathml-prefix mathml)
+(defprop mnot ("<mo>¬</mo> ") mathmlsym)
+(defprop mnot 70. mathml-rbp)
+
+(defprop mand mathml-nary mathml)
+(defprop mand ("<mo>∧</mo> ") mathmlsym)
+(defprop mand 60. mathml-lbp)
+(defprop mand 60. mathml-rbp)
+
+(defprop mor mathml-nary mathml)
+(defprop mor ("<mo>∨</mo> ") mathmlsym)
+
+;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
+;; etc
+
+(defun mathml-setup (x)
+ (let((a (car x))
+ (b (cadr x)))
+ (setf (get a 'mathml) 'mathml-prefix)
+ (setf (get a 'mathmlword) b) ;This means "sin" will always be roman
+ (setf (get a 'mathmlsym) (list b))
+ (setf (get a 'mathml-rbp) 130)))
+
+(mapc #'mathml-setup
+ '(
+ (%acos "<mi>arccos</mi> ")
+ (%asin "<mi>arcsin</mi> ")
+ (%atan "<mi>arctan</mi> ")
+ (%arg "<mi>arg</mi> ")
+ (%cos "<mi>cos</mi> ")
+ (%cosh "<mi>cosh</mi> ")
+ (%cot "<mi>cot</mi> ")
+ (%coth "<mi>coth</mi> ")
+ (%csc "<mi>cosec</mi> ")
+ (%deg "<mi>deg</mi> ")
+ (%determinant "<mi>det</mi> ")
+ (%dim "<mi>dim</mi> ")
+ (%exp "<mi>exp</mi> ")
+ (%gcd "<mi>gcd</mi> ")
+ (%hom "<mi>hom</mi> ")
+ (%inf "<mi>∞</mi> ")
+ (%ker "<mi>ker</mi> ")
+ (%lg "<mi>lg</mi> ")
+ ;;(%limit "<mi>lim</mi> ")
+ (%liminf "<mi>lim inf</mi> ")
+ (%limsup "<mi>lim sup</mi> ")
+ (%ln "<mi>ln</mi> ")
+ (%log "<mi>log</mi> ")
+ (%max "<mi>max</mi> ")
+ (%min "<mi>min</mi> ")
+ ; Latex's "Pr" ... ?
+ (%sec "<mi>sec</mi> ")
+ (%sech "<mi>sech</mi> ")
+ (%sin "<mi>sin</mi> ")
+ (%sinh "<mi>sinh</mi> ")
+ (%sup "<mi>sup</mi> ")
+ (%tan "<mi>tan</mi> ")
+ (%tanh "<mi>tanh</mi> ")
+ ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
+ ;(%laplace "{\\cal L}")
+ )) ;; etc
+
+(defprop mor mathml-nary mathml)
+(defprop mor 50. mathml-lbp)
+(defprop mor 50. mathml-rbp)
+
+(defprop mcond mathml-mcond mathml)
+(defprop mcond 25. mathml-lbp)
+(defprop mcond 25. mathml-rbp)
+
+(defprop %derivative mathml-derivative mathml)
+
+(defun mathml-derivative (x l r)
+ (mathml (mathml-d x "ⅆ") l r lop rop ))
+
+(defun mathml-d(x dsym) ;dsym should be "ⅆ" or "∂"
+ ;; 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '(mtimes)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mtimes)
+ ((mquotient) ,(simplifya numer nil) ,denom)
+ ,arg)))
+
+(defun mathml-mcond (x l r)
+ (append l
+ (mathml (cadr x) '("<mi>if</mi> <mspace width='mediummathspace'/>")
+ '("<mspace width='mediummathspace'/> <mi>then</mi><mspace width='mediummathspace'/> ") 'mparen 'mparen)
+ (if (eql (fifth x) '$false)
+ (mathml (caddr x) nil r 'mcond rop)
+ (append (mathml (caddr x) nil nil 'mparen 'mparen)
+ (mathml (fifth x) '("<mspace width='mediummathspace'/> <mi>else</mi><mspace width='mediummathspace'/> ") r 'mcond rop)))))
+
+(defprop mdo mathml-mdo mathml)
+(defprop mdo 30. mathml-lbp)
+(defprop mdo 30. mathml-rbp)
+(defprop mdoin mathml-mdoin mathml)
+(defprop mdoin 30. mathml-rbp)
+
+(defun mathml-lbp(x)(cond((get x 'mathml-lbp))(t(lbp x))))
+(defun mathml-rbp(x)(cond((get x 'mathml-rbp))(t(lbp x))))
+
+;; these aren't quite right
+
+(defun mathml-mdo (x l r)
+ (mathml-list (mathmlmdo x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathml-mdoin (x l r)
+ (mathml-list (mathmlmdoin x) l r "<mspace width='mediummathspace'/> "))
+
+(defun mathmlmdo (x)
+ (nconc (cond ((second x) `("<mi>for</mi> " ,(second x))))
+ (cond ((equal 1 (third x)) nil)
+ ((third x) `("<mi>from</mi> " ,(third x))))
+ (cond ((equal 1 (fourth x)) nil)
+ ((fourth x) `("<mi>step</mi> " ,(fourth x)))
+ ((fifth x) `("<mi>next</mi> " ,(fifth x))))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+(defun mathmlmdoin (x)
+ (nconc `("<mi>for</mi>" ,(second x) "<mi>in</mi> " ,(third x))
+ (cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
+ (cond ((null (seventh x)) nil)
+ ((eq 'mnot (caar (seventh x)))
+ `("<mi>while</mi> " ,(cadr (seventh x))))
+ (t `("<mi>unless</mi> " ,(seventh x))))
+ `("<mi>do</mi> " ,(eighth x))))
+
+;; Undone and trickier:
+;; Maybe do some special hacking for standard notations for
+;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
diff --git a/stack/2018080600/maxima/multiply_blank.lisp b/stack/2018080600/maxima/multiply_blank.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8299d076a99df596824a75e72ac37c9cff2759dc
--- /dev/null
+++ b/stack/2018080600/maxima/multiply_blank.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\, ") texsym)
diff --git a/stack/2018080600/maxima/multiply_cross.lisp b/stack/2018080600/maxima/multiply_cross.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ec0052c83f44c454a238de0e579d79121ebf2f3b
--- /dev/null
+++ b/stack/2018080600/maxima/multiply_cross.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\times ") texsym)
diff --git a/stack/2018080600/maxima/multiply_dot.lisp b/stack/2018080600/maxima/multiply_dot.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fb7cb69891f68486972dd35d406fe5a2b79fe1f8
--- /dev/null
+++ b/stack/2018080600/maxima/multiply_dot.lisp
@@ -0,0 +1,6 @@
+;; Customize Maxima's TEX() function.
+;; 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 mtimes ("\\cdot ") texsym)
diff --git a/stack/2018080600/maxima/noun_arith.lisp b/stack/2018080600/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3ffda4a9b0b67068f7d0b8ba9291b3b35212fbf1
--- /dev/null
+++ b/stack/2018080600/maxima/noun_arith.lisp
@@ -0,0 +1,47 @@
+;; 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)
+
+;; Chris Sangwin 3 Feb 2016.
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ and }}\\, ") texsym)
+(defprop $nounand 69. tex-lbp)
+(defprop $nounand 69. tex-rbp)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ or }}\\, ") texsym)
+(defprop $nounor 70. tex-lbp)
+(defprop $nounor 70. tex-rbp)
+
+;; Chris Sangwin 29 Sept 2017.
+
+(defprop mnot tex-prefix tex)
+(defprop mnot ("{\\rm not}") texsym)
\ No newline at end of file
diff --git a/stack/2018080600/maxima/rtest_assessment_simpboth.mac b/stack/2018080600/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bc02f607f7cb9219dbadde904a5e70c875460a14
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/rtest_assessment_simpfalse.mac b/stack/2018080600/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/rtest_assessment_simptrue.mac b/stack/2018080600/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6f71fbf308f39067a419f103f2f6e41a93f1d725
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/rtest_elementary.mac b/stack/2018080600/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/rtest_experimental.mac b/stack/2018080600/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/stack/2018080600/maxima/rtest_inequalities.mac b/stack/2018080600/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2498d27574c6e7dc113cb932b6f23b37ce4a1214
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/rtest_intervals.mac b/stack/2018080600/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d98bb969451810e6c345a7c556f536bb7fa17957
--- /dev/null
+++ b/stack/2018080600/maxima/rtest_intervals.mac
@@ -0,0 +1,77 @@
+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))$
+
+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$
+
+Intersection(%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))$
+
+ListIntersect([%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))$
+
+Complement(%union(oo(0,1),oo(2,3),oo(3,inf)));
+%union(cc(1,2),{3},oc(-inf,0))$
diff --git a/stack/2018080600/maxima/sandbox.wxm b/stack/2018080600/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..9685a9bec631f03df4dfe1f6260dc25ba9c18d8d
--- /dev/null
+++ b/stack/2018080600/maxima/sandbox.wxm
@@ -0,0 +1,88 @@
+/* [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. Download the files from github, either using git or as a zip file.
+2. Place the files somewhere they can be read, and edit the line velow to give the location.
+ E.g. Place the files in C:\files\stack
+3. Specify a directory for temporary working files, e.g. 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 ] */
+/* In MS platforms use the forward slash as a directory seperator. No trailing slash. */
+stacklocation:"C:/files/stack"$
+stacktmplocation:"C:/tmp"$
+
+/****************************************************
+ There should be no need to edit below this line.
+
+ These commands add the location to Maxima's search path.
+*/
+file_search_maxima:append( [sconcat(stacklocation, "/question/type/stack/stack/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/question/type/stack/stack/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:"win",
+ 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.41.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: comment start ]
+To time code, and spot inefficiencies.
+
+timer(all)$
+
+We need some lisp to turn the atom $SEC into 1, (%SEC is a function....)
+:lisp (msetq $SEC 1)
+
+[Execute some code...]
+
+This returns the list of functions actually called.
+l:sublist(args(timer_info()), lambda([ex], is(third(ex)>0)));
+
+Sort according to function called most often
+sort(l,lambda([a,b], is(third(a)>third(b))));
+
+Sort according to time per call
+sort(l,lambda([a,b], is(second(a)>second(b))));
+
+ [wxMaxima: comment end ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2018080600/maxima/stackmaxima.mac b/stack/2018080600/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..73fecf37db3d6466b5b8537e75966090fa40a32a
--- /dev/null
+++ b/stack/2018080600/maxima/stackmaxima.mac
@@ -0,0 +1,2854 @@
+/* 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,
+ 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),
+
+ /*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(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 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 */
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+load ("functs");
+
+/* 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");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+alias(arccos, acos); /* At the request of the OU, 4 Feb 2013. */
+alias(arcsin, asin);
+alias(arctan, atan);
+
+load("mathml.lisp");
+
+make_complexJ(OPT_COMPLEXJ) := block(
+ if OPT_COMPLEXJ = "i" then
+ (i:%i,load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "j" then
+ (%j:%i,j:%i,load("complexj.lisp"))
+ else if OPT_COMPLEXJ = "symi" then
+ (load("complexi.lisp"))
+ else if OPT_COMPLEXJ = "symj" then
+ (load("complexj.lisp"))
+ else true
+);
+
+/* Choose the symbol for the multiplication sign. */
+make_multsgn(OPT_MULTSGN) := block(
+ if OPT_MULTSGN = "cross" then load("multiply_cross.lisp"),
+ if OPT_MULTSGN = "dot" then load("multiply_dot.lisp"),
+ if OPT_MULTSGN = "blank" then load("multiply_blank.lisp")
+);
+
+/* Options for cos^(-1), acos or arccos. */
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then load("cos-1.lisp"),
+ if OPT_ACOS = "arccos" then load("arccos.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))
+)$
+
+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 (
+ print("rand_selection error: first argument must be a list."),
+ return([])
+ ),
+ if not(integerp(n)) then (
+ print("rand_selection error: second argument must be an integer."),
+ return([])
+ ),
+ if is(n>length(ex)) then (
+ print("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 three 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(ex[2]-ex[1]), simp)),
+ if not(integerp(ex[3])) then error("rand_range expects its first argument to be an integer."),
+ if is(length(ex)=3) then return(ev(ex[1]+ex[3]*rand(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> ", 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)))))
+)$
+
+/* ********************************** */
+/* 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:"\\]"),
+ expstr: tex(expru, false),
+ expstr: concat(ld, stack_disp_strip_dollars(expstr), rd)
+ ),
+ /* MathML display */
+ if OPT_OUTPUT = "MathML" then
+ str: mathml(expr, false),
+ /* 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
+ 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, "_"),
+ s: maplist(parse_string, 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)))
+)$
+
+/* ********************************** */
+/* 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)
+)$
+
+detexdecorate(ex) := block([argsex],
+ if mapatom(ex) then return(ex),
+ argsex:args(ex),
+ if op(ex) = texdecorate then return(detexdecorate(argsex[2])),
+ if op(ex) = "/" then return(detexdecorate(argsex[1])/detexdecorate(argsex[2])),
+ map(detexdecorate, ex)
+)$
+
+/* Assume all non-numeric atoms are to be displayed in bold. */
+texboldatoms(ex) := block(
+ if numberp(ex) then return(ex),
+ if atom(ex) then return(texdecorate("\\bf", ex)),
+ if arrayp(ex) then return(arraymake(op(ex), maplist(texboldatoms, args(ex)))),
+ apply(op(ex), maplist(texboldatoms, args(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 (print("\\mbox{ERROR: argument to stack_matrix_disp must be a matrix.} "), return("")),
+ if not(stringp(lmxchar)) then (print("\\mbox{ERROR: stack_matrix_disp requires lmxchar to be a string. }"), return("")),
+ parens: sublist(stack_matrix_pairs, lambda([ex], is(first(ex)=lmxchar))),
+ if emptyp(parens) then (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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))
+)$
+
+/* ********************************************************************* */
+/* 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(
+ ex: detexcolor(ex),
+ ex: detexdecorate(ex),
+ ex: make_displaydpvalue(ex),
+ ex: make_displayscivalue(ex),
+ if not(stack_disp_control_structurep(ex)) then
+ ex: unary_minus_sort(opsubst("*", stackunits, ex)),
+ return(string(ex))
+)$
+
+/* ********************************** */
+/* 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: concat(fb, "stack_trans('", key, "'", exprs, "); !NEWLINE!"),
+ return(str)
+)$
+
+/* Separate notes with puncutation, to enable clearer reading
+ and the possibility to split them. */
+StackAddNote(exnote, 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)]$
+
+/* ********************************************************* */
+/* Turns answertest output to a STACK return object string */
+/* */
+/* ex[1] = validity should be true/false */
+/* ex[2] = result should be true/false, */
+/* ex[3] = feedback, a string */
+/* ex[4] = answernote, is for teacher stats */
+/* */
+/* ********************************************************* */
+
+StackReturn(ex) := block([str],
+ if not(listp(ex)) then
+ (print("StackReturn failed: argument not a list: "), print(string(ex)), return("")),
+ if length(ex)#4 then
+ (print("StackReturn failed: argument wrong length: "), print(string(ex)), return("")),
+ print(" ], valid = [ "),
+ if ex[1] then print(1) else print(0),
+ print(" ], answernote = [ "),
+ print(ex[3]),
+ print(" ], feedback = [ "),
+ print(ex[4]),
+ return(ex[2])
+)$
+
+/* 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 */
+/* ******************************************* */
+
+stack_validate(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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. */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms. */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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"))),
+ /* Check if the student's answer is the same type as the Teacher's. */
+ SameType:ATSameTypefun(expr, TAns),
+ if SameType[2]#true then print(SameType[4]),
+ /* Now display the result. */
+ simp: false,
+ expr: detexcolor(expr),
+ expr: detexdecorate(expr),
+ return(expr)
+)$
+
+/* Validate an expression without type checking. Floats and mathematical errors only. */
+stack_validate_typeless(expr, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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 */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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)
+)$
+
+/* These functions convert all variables in an expression to products of single letter variable names. */
+stack_singlevar_make_helper(ex) := block([s],
+ s: maplist(eval_string, charlist(string(ex))),
+ apply("*", s)
+)$
+
+stack_singlevar_make(ex) := block([vars, subs],
+ vars: sublist(listofvars(ex), lambda([ex], if slength(string(ex))>1 then true else false)),
+ if emptyp(vars) then return(ex),
+ vars:maplist(lambda([ex], ex=stack_singlevar_make_helper(ex)), vars),
+ /* We only need to use associtativity of "*", not "+", but we have to do it over the whole expression. */
+ STACK_assoc(sublis(vars, ex), ["*"])
+)$
+
+/* 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],
+ 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(logbase, ex)) then
+ ex:ev(ex, logbase=logbasesimp),
+ lvs: listofvars(ex),
+ lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
+ if length(lvs)>1 then
+ (print(concat("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /*********************/
+ /* 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ /*******************/
+ /* 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
+ (print(concat("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /********************************************/
+ /* 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='", alttext, "' width='", string(plot_size[1]), "' />"),
+ if plot_tags then
+ ufn: concat("<div class='stack_plot'>", ufn, "</div>"),
+ if OPT_OUTPUT#"MathML" then
+ 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(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"))]),
+
+ SA:sort(float(listify(SA))),
+ SB:sort(float(listify(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([Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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 not(integerp(nsf) and integerp(asf)) then
+ (print("TEST_FAILED"),return([false, false, StackAddNote("", "ATNumSigFigs_STACKERROR_not_integer"), StackAddFeedback("", "TEST_FAILED_Q")])),
+ /* SA should be only a number. */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ SA:SAA[1],
+ if (not(floatnump(SA)) and not(integerp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* 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 not(is(sign(SA)=sign(SB))) 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.
+ This changes 1.5 -> 2.0 (2.s.f). */
+ SB:significantfigures(SB, nsf),
+ /* Puts Teacher's answer 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,
+ 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)
+)$
+
+/* ********************************** */
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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, eg 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([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 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 an equation? */
+ /* Don't use logic_edgep(SB) here, as this include "true" and "false". A teacher should use all/none if they mean equations. */
+ if (equationp(SB) or SB = all or SB = none) then
+ /* But the student can also use true/false here. Note the concious asymetry. */
+ if (equationp(SA) or logic_edgep(SA)) then
+ return(ATEquation(SA, SB))
+ else if equationp(SB) and not equationp(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, "+-"))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ /* Are we dealing with an inequality? */
+ if inequalityp(SB) then
+ if inequalityp(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)),
+ /* 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)
+)$
+
+/* 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]),
+ SA1:args(SA), SAd1:second(SA1),
+ SB1:args(SB), SBd1:second(SB1),
+ /* 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]),
+ FeedBack:StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i")),
+ if (SAr#SBr) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), FeedBack]),
+ if (SAc#SBc) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), FeedBack]),
+ FeedBack:"",
+ /* 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, str, SAl, SBl, ZM],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Get sizes of matrices */
+ SAl:cardinality(SA),
+ SBl:cardinality(SB),
+ FeedBack:StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i")),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ SA:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong ? */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "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],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Turn on simplification and error catch */
+ SAsimp:errcatch(ev(SA, simp, nouns)),
+ if is(SAsimp = [STACKERROR]) then return([false, false, StackAddNote("", "ATSets_STACKERROR_SAns"), ""]),
+ SAsimp:SAsimp[1],
+ SBsimp:errcatch(ev(SB, simp, nouns)),
+ if is(SBsimp = [STACKERROR]) then return([false, false, StackAddNote("", "ATSets_STACKERROR_TAns"), ""]),
+ SBsimp:SBsimp[1],
+ 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")),
+
+ /* 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])
+)$
+
+/* 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,"+-")=1), simp) then SA:pm_replace(SA),
+ if ev(is(count_op(SB,"+-")=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, "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, "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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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 */
+ 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"),""]),
+
+ /* 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 not is(ev(setify(listofvars(S1)),simp)=ev(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, ""]) else
+ 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,""]) else
+ if op(SB) = "+" then return(irred_Q(SB, SO)) else
+ 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),
+ /* 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: StackReturn */
+/* 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:StackAddFeedback("",""), 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****************************** */
+/* requires: Student Answer */
+/* List: [Teachers Answer, variable with which partial */
+/* fraction occurs, whether Formative Feedback is required */
+/* returns: StackReturn */
+/* Cases: */
+/* Returns True iff algebraic equivalence with TList[1] */
+/* and Division is the Top Operator. */
+/* False if Division not the top operator */
+/* False if different Variables are used */
+/* True(0) otherwise */
+/* ******************************************************************** */
+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 op(SAA) = "/" then block(
+ if (freeof("/", num(SAA)) and freeof("/", denom(SAA))) then block(
+ rawmk:true,
+ ansnote:"ATSingleFrac_true")
+ else 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])
+)$
+
+
+/*****************************************************************/
+/* Useful function for Partial Fractions */
+/*****************************************************************/
+
+divthru(q) :=
+ if (not atom(q) and part(q,0)="/")
+ then
+ block([num, den, div, quo, rem],
+ num:part(q, 1),
+ den:part(q, 2),
+ div:divide(num, den) ,
+ quo:div[1],
+ rem:div[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(SBL[2], "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 */
+ 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])="^" 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"), ""]),
+
+ 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:"",
+ debug:false,
+ 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
+);
+
+/********************************************************************/
+/* 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:true, 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"),""]),
+
+ /* 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 algebraic_equivalence(diff(SA,v),int(SB,v)) 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)
+ )$
+
+/* ****************************************************** */
+/* */
+/* 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("")
+)$
+
+/* 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:2018080600$
diff --git a/stack/2018080600/maxima/stackreporting.mac b/stack/2018080600/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93
--- /dev/null
+++ b/stack/2018080600/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(
+ print("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/2018080600/maxima/stackstrings.mac b/stack/2018080600/maxima/stackstrings.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d26cae12094dfab583e57b95802aef10af053e11
--- /dev/null
+++ b/stack/2018080600/maxima/stackstrings.mac
@@ -0,0 +1,236 @@
+/* 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 withing 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) := listp(x) and is(length(x)>0) and is(x[1]="stack_map")$
+/* might as we be called stackmapp() but that sounds odd. */
+stackmapp(x) := is_stackmap(x)$
+
+stackmap_get(m, k) := block([tmp, val],
+ val:und,
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if (not is(tmp="stack_map")) and is(tmp[1]=k) then (val:tmp[2],return(tmp[2])),
+ return(val)
+)$
+
+stackmap_set(m, k, v) := block([tmp, found, r],
+ found: false,
+ r: ["stack_map"],
+ /* If we are given anything else than a map as the map we make a new map. */
+ if not is_stackmap(m) then return(append(r,[[k,v]])),
+ for tmp in m do if not is(tmp="stack_map") then (if is(tmp[1]=k) then (r:append(r,[[k,v]]),found:true) else r:append(r,[tmp])),
+ if not found then r:append(r,[[k,v]]),
+ return(r)
+)$
+
+stackmap_unset(m, k) := block([tmp, r],
+ r: ["stack_map"],
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then (if not is(tmp[1]=k) then r:append(r,[tmp])),
+ return(r)
+)$
+
+stackmap_keys(m) := block([tmp, r],
+ r: [], /* Might as well be a set but then we would lose the direct match to the values list... */
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then r:append(r,[tmp[1]]),
+ return(r)
+)$
+
+stackmap_values(m) := block([tmp, r],
+ r: [],
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then r:append(r,[tmp[2]]),
+ return(r)
+)$
+
+stackmap_has_key(m, k) := block([tmp, found],
+ found: false,
+ if not is_stackmap(m) then return(false),
+ for tmp in m do if not is(tmp="stack_map") then (if is(tmp[1]=k) then found:true),
+ 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) then r:sconcat("[",simplode(makelist(stackjson_stringify(x),x,obj),","),"]")
+ 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)
+)$
diff --git a/stack/2018080600/maxima/stacktex.lisp b/stack/2018080600/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..14314d9fdb22b3838d716b6696e4373adee7474d
--- /dev/null
+++ b/stack/2018080600/maxima/stacktex.lisp
@@ -0,0 +1,351 @@
+;; 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)
+
+(defun tex-texdecorate (x l r)
+ (let
+ ((front (append '("{")
+ (list (stripdollar (cadr x)))
+ '("")))
+ (back (append '("{")
+ (tex (caddr x) nil nil 'mparen 'mparen)
+ '("}}"))))
+ (append l front back r)))
+
+(defprop $texdecorate tex-texdecorate 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 (odds difflist 0)) ;; e.g. (1 2)
+ (vars (odds difflist 1)) ;; e.g. (x y)
+ (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (denom (cons '($blankmult)
+ (mapcan #'(lambda(b e)
+ `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ vars ords))))
+ `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom)
+ ))
+
+
+(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 $+-) :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))))
+
+;; Sort out binding power of %union to display correctly.
+;; tex-support is defined in to_poly_solve_extra.lisp.
+(defprop $%union 115. tex-rbp)
diff --git a/stack/2018080600/maxima/stacktex40.lisp b/stack/2018080600/maxima/stacktex40.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2f688179b2c7d0573e3db8a3caef343746f7fbae
--- /dev/null
+++ b/stack/2018080600/maxima/stacktex40.lisp
@@ -0,0 +1,91 @@
+;; 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 $+-) :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)))
+
+;; *************************************************************************************************
+;; 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) (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/2018080600/maxima/stackunits.mac b/stack/2018080600/maxima/stackunits.mac
new file mode 100644
index 0000000000000000000000000000000000000000..cb1de594778417ce3216cc99fab0799c97cd26fb
--- /dev/null
+++ b/stack/2018080600/maxima/stackunits.mac
@@ -0,0 +1,570 @@
+/* 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}"],
+*/
+
+/* Add rules to the simplifier to deal with stackunits. */
+matchdeclare(STACKNUM1, all, STACKNUM2, all, STACKUNITS1, all, STACKUNITS2, all, STACKNUM, numberp)$
+matchdeclare(STACKANY, all)$
+tellsimpafter(STACKNUM*stackunits(STACKNUM1,STACKUNITS1), stackunits(STACKNUM*STACKNUM1, STACKUNITS1));
+tellsimpafter(stackunits(STACKNUM1, STACKUNITS1)^STACKNUM, stackunits(STACKNUM1^STACKNUM, STACKUNITS1^STACKNUM));
+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)+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 is 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)="+-") 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 a product we are return what we are given. */
+ if 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(
+ print("fracdisp argument to stack_validate_units 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),
+
+ /* 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)="+-")) 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),
+ expr:detexdecorate(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 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. */
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "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, SAU1, SBU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ SAA:errcatch(ev(SA, simp, nouns)),
+ if (is_simp(SAA = [STACKERROR]) or is_simp(SAA = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is_simp(SBB = [STACKERROR]) or is_simp(SBB = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is_simp(SOO = [STACKERROR]) or is_simp(SOO = [])) 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 (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU)),
+
+ /* 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, ol])),
+ if (numtest = "SigFigs") then
+ ret1: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret1: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret1: ATNumRelative(SAU1, SBU1, ol)
+ 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]]),
+
+ /* 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),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(SB),
+ if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU)),
+ /* Check the accuracy again, now we have converted. */
+ SAU1:ev(float(stack_units_nums(SAU)), simp),
+ SBU1:ev(float(stack_units_nums(SBU)), simp),
+ if (numtest = "SigFigs") then
+ ret2: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret2: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret2: ATNumRelative(SAU1, SBU1, ol)
+ 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/2018080600/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2018080600/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d4e798fd0706ced74f70dd61ce6c9a3d2f943b85
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/unittests_load.mac b/stack/2018080600/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..072158a1c3ce7b06181b68fe7c37e507718f471b
--- /dev/null
+++ b/stack/2018080600/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/2018080600/maxima/utils.mac b/stack/2018080600/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..940f0fadcf9004fd103dfc8713dfb71d86ad3f35
--- /dev/null
+++ b/stack/2018080600/maxima/utils.mac
@@ -0,0 +1,115 @@
+/* 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)
+)$
+
+
+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/2019090200/maxima/assessment.mac b/stack/2019090200/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8039b153531d7f99fae301e5c50c67b191345913
--- /dev/null
+++ b/stack/2019090200/maxima/assessment.mac
@@ -0,0 +1,2266 @@
+/* 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)$
+
+/* ********************************** */
+/* 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)
+)$
+
+/* 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 not(real_numberp(x)) then error("sigfigsfun(x,n,d) requires a real number 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.
+*/
+
+
+/* ********************************** */
+/* 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/9/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.
+*/
+algebraic_equivalence(SA, SB) :=
+ block([keepfloat, trigexpand, logexpand, ex, vi],
+ /* Reject obviously different expressions. These can be very time consuming in the tests below. */
+ /* The code below is actually making the situation worse: needs reconsidering. */
+ 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 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating collectterms threw an error."), return(false)),
+ ex:ex[1],
+ ex:errcatch(ev(radcan_num(ex), simp)),
+ if ex=[] then (print("algebraic_equivalence: evaluating radcan_num an error."), return(false)),
+ 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 (print("algebraic_equivalence: factoring the difference of two expressions threw an error."), return(false)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ ex:errcatch(ratsimp(ex)),
+ if ex=[] then (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ 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)),
+ if abs(first(pval)) > 1/10000 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)),
+ sz:errcatch(ev(abs(float(first(p1)-first(p2))), 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);
+
+verb_arith(ex) := block(
+ 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(
+ 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)="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"), ""]),
+
+ /* 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)$
+
+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) = "and" then return(true),
+ if safe_op(ex) = "or" then return(true),
+ if safe_op(ex) = "not" then return(true),
+ if op_usedp(ex, "+-") 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", "and", "or", "%and", "%or", "not", "%not", "+-", "<", ">", "<=", ">=", "=", "[", "{"],
+ 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:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", 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)
+)$
+
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ return(rex)
+)$
+
+/****************************************************************/
+/* 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. */
+prefix("+-");
+nary("+-", 100);
+
+displaypmtex(ex):=block([al, a1, a2],
+ al:args(ex),
+ if is(length(al)=1) then
+ return(sconcat(" \\pm ", tex1(first(al)))),
+ a1:tex1(first(al)),
+ a2:tex1(second(al)),
+ sconcat("{", a1, " \\pm ", a2, "}")
+ );
+texput("+-", 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, "+-")=1), simp) then return(opsubst("+", "+-", ex) nounor opsubst("-", "+-", 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 ev(argfac=factor(argfac), simp) then
+ return(true),
+ if mapatom(argfac) then
+ return(false),
+ /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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 (
+ print("comp_square: var should be an atom but not a number. "),
+ return(ex)
+ ),
+ ex:ratsimp(expand(ex)),
+ if not(polynomialp(ex, [var])) then (
+ print("comp_square: ex should be a polynomial in var. "),
+ return(ex)
+ ),
+ if hipow(ex, var)#2 then (
+ print("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);
+
+/* 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 (print("stack_disp_arg expects to receive a list."), return(false)),
+ 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,"+-")=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],
+
+ 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(
+ ex2:ev(solve(ex2, sort(listofvars(ex2)))), simp),
+ if assume_real then
+ ex2:ev(sublist(ex2, lambda([m], freeof(%i, m))), simp),
+ if not(emptyp(ex2)) then (ex2:map(lambda([ex], apply("%and", ex)), ex2), ex:apply("%or", ex2))
+ ),
+ 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
+ res:unknown
+ 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 (
+ print("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/2019090200/maxima/assessment.texi b/stack/2019090200/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/elementary.mac b/stack/2019090200/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..77cb7ddc99b1fb2410361c1cefb654b41cc414ed
--- /dev/null
+++ b/stack/2019090200/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 print("ERROR: 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/2019090200/maxima/expandfeedback.mac b/stack/2019090200/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/experimental.mac b/stack/2019090200/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..98afe06e41c2d99210e1ca9301fcd43e1b447811
--- /dev/null
+++ b/stack/2019090200/maxima/experimental.mac
@@ -0,0 +1,175 @@
+/* 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))));
+
+/****************************************************************/
+/* Inequality functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* V0.2 July 2013 */
+/* */
+/****************************************************************/
+
+/****************************************************************/
+/* Reporting support functions for STACK */
+/* */
+/* Chris Sangwin, <chris@sangwin.com> */
+/* 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 (print("STACK exception: node_no expects its first argument to be a list."), return(false)),
+ if not(integerp(num)) then (print("STACK exception: node_no expects its second argument to be an integer."), return(false)),
+ if is(length(prt)<num) then (print("STACK exception: node_no expects its second argument to less than the length of the first."), return(false)),
+ /* 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 (print("STACK exception: traverse_prt expects its argument to be a list."), return(false)),
+ if not(alllistp(equationp,inputs)) then (print("STACK exception: traverse_prt expects its argument to be a list of equations."), return(false)),
+ /* 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, <chris@sangwin.com> */
+/* 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/2019090200/maxima/inequalities.mac b/stack/2019090200/maxima/inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..ff1fb41618b225e1099705c0fdabd6a2642730f5
--- /dev/null
+++ b/stack/2019090200/maxima/inequalities.mac
@@ -0,0 +1,305 @@
+/* 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 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 print("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/2019090200/maxima/intervals.mac b/stack/2019090200/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..3aba6d0bda843bea8887941ccb7828b0c4444c54
--- /dev/null
+++ b/stack/2019090200/maxima/intervals.mac
@@ -0,0 +1,1027 @@
+/* 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 intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.2 June 2017 */
+/* */
+/********************************************************************/
+
+/* 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
+ );
+*/
+
+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(Complement(b), simp),
+ if 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)],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(false),
+ 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 setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(intervalp, args(ex))),
+ 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=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 atom(ex) then return(false),
+ if setp(ex) and ex={} then return(true),
+ if save_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)
+)$
+
+SimpleUnion(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 setp(A) then
+ (
+ if 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 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 setp(A) or atom(B) or 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:SimpleUnion( 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)
+ )
+ )
+ )
+ )
+ ),
+ if safe_op(Ans)="[" then Ans:apply(%union, Ans),
+ Ans
+ );
+
+
+/* Finds the intersection of two "simple" sets: */
+SimpleIntersect(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 Ans:{} elseif
+ atom(B) then Ans:{} elseif
+ setp(A) then
+ (
+ if setp(B) then
+ (
+ return(intersect(A,B))
+ )
+ else
+ (
+ 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:{}
+ )
+ )
+ elseif setp(B) then
+ (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do
+ (if inintervalp(Aset[i],A) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans:setAns ) else Ans:{}
+ ),
+ if ( not atom(A) and not atom(B) ) then
+ (
+ Args1:args(A),
+ Args2:args(B),
+
+ if (not atom(A) and not(op(A)=set) and not atom(B) and not(op(B)=set) ) 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:{},
+ 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
+ );
+
+SimpDisjointp(A,B) := if SimpleIntersect(A,B)={} then true else false;
+
+/* Given a *list* of disjoint intervals, returns the same intervals but in ascending order: */
+SortUnion(X) :=
+ block ( [A:X, Ans:[], x, n, i],
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ if ( first( A[i] ) < first( x ) ) then x:A[i],
+ i:i+1
+ ),
+ Ans:append( Ans, [x] ),
+ A:delete( x, A, 1 ),
+ n:n-1
+ ),
+ Ans
+ );
+
+/* Given a union of disjoint intervals, checks whether any intervals are connected, and if so, joins them up and returns the ammended union: */
+ConnectIntervals(X):=
+ block ( [Ans, n, x, y, i:1],
+
+ if not(op(X)=%union) then error("ConnectIntervals requires a %union of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ if last( Ans[i] ) >= first( Ans[i+1] ) then
+ (
+ x:SimpleUnion( Ans[i], Ans[i+1] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[i+1], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ n:n-1,
+ i:i-1
+ )
+ ),
+ 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: */
+TidyUnion(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),
+
+ if (not (op(X)=%union or op(X)="[") ) then Ans:X
+ else
+ (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<n+1 do
+ (
+ if ( setp(A[i]) ) then
+ (
+ setpart:union( setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ )
+ else if ( trivialintervalp(A[i]) ) then
+ (
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ ),
+ i:i+1
+ ),
+ A:SortUnion(A),
+ if is(length(A)>1) then
+ A:ConnectIntervals(apply(%union, A)),
+ if length(setpart)>0 then A:append( args(A), [setpart] ),
+ if is(length(A)=1) then
+ A:first(A),
+ Ans:A
+ ),
+ Ans
+ )$
+
+/* Finds the union of any two sets: */
+Union(X, Y) :=
+ block ( [A, B, Ans:[], Joined:[], sets:{}, add, temp, x, y, m, n, k, i:1, j:1, f:1],
+ if atom(X) then Ans:Y
+ elseif atom(Y) then Ans:X
+ else
+ (
+
+ A:X,
+ if op(X)=%union then A:args(X),
+ B:Y,
+ if op(Y)=%union then B:args(Y),
+
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleUnion(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:Union(A,B) )
+ else
+ (
+ while i<(m+1)do
+ (
+ if op( A[i] ) = set then
+ (
+ sets:SimpleUnion( sets , A[i] ),
+ A:delete( A[i] , A , 1 ),
+ i:i-1,
+ m:m-1
+ ),
+ i:i+1
+ ),
+ i:1,
+ while j<(n+1)do
+ (
+ if op( B[j] ) = set then
+ (
+ sets:SimpleUnion( sets , B[j] ),
+ B:delete( B[j] , B , 1 ),
+ j:j-1,
+ n:n-1
+ ),
+ j:j+1
+ ),
+ j:1,
+ temp:Ans,
+
+ Joined:append(A,B),
+ Joined:JoinedUnion(Joined),
+ temp:append(temp,Joined),
+
+ if length(sets)>0 then
+ (
+ sets:listify(sets),
+ m:length(temp),
+ n:length(sets),
+ while j<(n+1) do
+ (
+ while i<(m+1) do
+ (
+ x:first( temp[i] ),
+ y:last( temp[i] ),
+ if inintervalp( sets[j], temp[i] ) then
+ (
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ )
+ elseif ( sets[j]=x or sets[j]=y ) then
+ (
+ temp[i]:Union( temp[i], { sets[j] } ) ,
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ ),
+ i:i+1
+ ),
+ i:1,
+ j:j+1
+ ),
+ j:1,
+ if length(sets)>0 then
+ (
+ sets:setify(sets),
+ temp:cons(sets,temp)
+ )
+ ),
+ if length(temp)=1 then temp:temp[1],
+ Ans:temp
+ )
+ ),
+ Ans:TidyUnion(Ans)
+ ),
+
+ Ans
+ );
+
+/* When given a union of intervals, this function simplifies the union by joining up any connected intervals: */
+JoinedUnion(X) :=
+ block ( [A, nextA:[], disjoint:[], temp, Ans:[], n, i, j, alldisjoint:false, Joined:[] ],
+
+ A:X,
+ if op(A)=%union then A:args(A),
+ while alldisjoint = false do
+ (
+ alldisjoint:true,
+ n:length(A),
+ disjoint:[],
+ i:1,
+ while i<n+1 do
+ (
+ disjoint: append(disjoint, [true] ),
+ i:i+1
+ ),
+ i:1,
+ while i<n do
+ (
+ j:i+1,
+ while j<n+1 do
+ (
+ if ( SimpDisjointp( A[i], A[j] ) ) then
+ (
+ if disjoint[j] = true then
+ (
+ nextA:delete( A[j], nextA, 1),
+ nextA:append(nextA, [ A[j] ] )
+ )
+ )
+ else (
+ nextA:delete( A[i], nextA, 1),
+ nextA:delete( A[j], nextA, 1),
+ temp:SimpleUnion( A[i], A[j] ),
+ if ( not op(temp) = "[" ) then temp:[temp],
+ nextA:append(nextA, temp ),
+ disjoint[i]:false,
+ disjoint[j]:false,
+ alldisjoint:false
+ ),
+ j:j+1
+ ),
+ if disjoint[i] = true then
+ (
+ nextA:delete( A[i], nextA, 1 ),
+ nextA:append(nextA, [ A[i] ] )
+ ),
+ i:i+1
+ ),
+ if alldisjoint = false then A:nextA,
+ nextA:[]
+ ),
+ Ans:A,
+ Ans
+ );
+
+Intersection(X,Y) :=
+ block ([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if is(A=all) then return(B)
+ elseif is(B=all) then return(A)
+ elseif atom(A) then Ans:{}
+ elseif atom(B) then Ans:{}
+ else
+ (
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleIntersect(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:SimpleIntersect(A,B) )
+ else
+ (
+ while i<m+1 do
+ (
+ while j<n+1 do
+ (
+ temp:SimpleIntersect( A[i], B[j] ),
+ if not atom(temp) then
+ (
+ Ans:append( Ans, [temp] )
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ )
+ ),
+ if (not atom(Ans)) and op(Ans) = "[" then
+ (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ )
+ ),
+ Ans:TidyUnion(Ans),
+ Ans
+ );
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+ListIntersect(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:Intersection(Ans,A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+OrderPoints(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:TidyUnion(A),
+ if op( last(A) ) = set 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
+ );
+
+
+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( Ans:oo(-inf,inf) ),
+ if not (op(A) = "[" or op(A)=%union) then
+ (
+ if op(A)=set then Ans:SetComplement(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:OrderPoints(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(ListIntersect(maplist(lambda([ex2], TidyUnion(Complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ else if listp(Ans) then
+ Ans:apply(%union, Ans)
+ ),
+
+ Ans
+ );
+
+SetComplement(X):=
+ block ( [A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("SetComplement 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("%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), realsetp), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realsetp(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, realsetp), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realsetp(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([TidyUnion(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([ListIntersect(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: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(realsetp(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:ListIntersect(ex2),
+ ex2
+)$
diff --git a/stack/2019090200/maxima/noun_arith.lisp b/stack/2019090200/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..81f1d09ecd1ab19dee69a3ae23bff6c51c0e29df
--- /dev/null
+++ b/stack/2019090200/maxima/noun_arith.lisp
@@ -0,0 +1,47 @@
+;; 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)
+
+;; Chris Sangwin 3 Feb 2016.
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+(defprop $nounand 69. tex-lbp)
+(defprop $nounand 69. tex-rbp)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+(defprop $nounor 70. tex-lbp)
+(defprop $nounor 70. tex-rbp)
+
+;; Chris Sangwin 29 Sept 2017.
+
+(defprop mnot tex-prefix tex)
+(defprop mnot ("{\\rm !NOT!}") texsym)
\ No newline at end of file
diff --git a/stack/2019090200/maxima/rtest_assessment_simpboth.mac b/stack/2019090200/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bc02f607f7cb9219dbadde904a5e70c875460a14
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/rtest_assessment_simpfalse.mac b/stack/2019090200/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/rtest_assessment_simptrue.mac b/stack/2019090200/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6f71fbf308f39067a419f103f2f6e41a93f1d725
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/rtest_elementary.mac b/stack/2019090200/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/rtest_experimental.mac b/stack/2019090200/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/stack/2019090200/maxima/rtest_inequalities.mac b/stack/2019090200/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2498d27574c6e7dc113cb932b6f23b37ce4a1214
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/rtest_intervals.mac b/stack/2019090200/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d98bb969451810e6c345a7c556f536bb7fa17957
--- /dev/null
+++ b/stack/2019090200/maxima/rtest_intervals.mac
@@ -0,0 +1,77 @@
+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))$
+
+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$
+
+Intersection(%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))$
+
+ListIntersect([%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))$
+
+Complement(%union(oo(0,1),oo(2,3),oo(3,inf)));
+%union(cc(1,2),{3},oc(-inf,0))$
diff --git a/stack/2019090200/maxima/sandbox.wxm b/stack/2019090200/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..1460ca3d027cfee5cfca214bca46a72f6c58e32c
--- /dev/null
+++ b/stack/2019090200/maxima/sandbox.wxm
@@ -0,0 +1,99 @@
+/* [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: comment start ]
+To time code, and spot inefficiencies.
+
+timer(all)$
+
+We need some lisp to turn the atom $SEC into 1, (%SEC is a function....)
+:lisp (msetq $SEC 1)
+
+[Execute some code...]
+
+This returns the list of functions actually called.
+l:sublist(args(timer_info()), lambda([ex], is(third(ex)>0)));
+
+Sort according to function called most often
+sort(l,lambda([a,b], is(third(a)>third(b))));
+
+Sort according to time per call
+sort(l,lambda([a,b], is(second(a)>second(b))));
+
+ [wxMaxima: comment end ] */
+
+/* Maxima can't load/batch files which end with a comment! */
+"Created with wxMaxima"$
diff --git a/stack/2019090200/maxima/stackmaxima.mac b/stack/2019090200/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8f31e19fc9e71e069419eaba4d99a0ee76739c89
--- /dev/null
+++ b/stack/2019090200/maxima/stackmaxima.mac
@@ -0,0 +1,2940 @@
+/* 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),
+
+ /*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 */
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+
+/* ********************************** */
+/* Load contributed packages */
+/* ********************************** */
+
+load("functs");
+/* Not yet testsed: load("vect"); */
+
+/* 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");
+/* Ensure back compatability with versions before 5.41.0. */
+if is(MAXIMA_VERSION_NUM<40.1) then load("stacktex40.lisp");
+load("utils.mac");
+
+/* Breaks on older versions of Maxima. */
+if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$
+
+texput(QMCHAR, "\\color{red}{?}");
+texput(theta, "\\theta");
+
+alias(arccos, acos); /* At the request of the OU, 4 Feb 2013. */
+alias(arcsin, asin);
+alias(arctan, atan);
+
+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)
+);
+
+/* 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 (
+ print("rand_selection error: first argument must be a list."),
+ return([])
+ ),
+ if not(integerp(n)) then (
+ print("rand_selection error: second argument must be an integer."),
+ return([])
+ ),
+ if is(n>length(ex)) then (
+ print("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> ", 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)))))
+)$
+
+/* ********************************** */
+/* 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:"\\]"),
+ expstr: tex(expru, false),
+ 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, "_"),
+ s: maplist(parse_string, 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 (print("\\mbox{ERROR: argument to stack_matrix_disp must be a matrix.} "), return("")),
+ if not(stringp(lmxchar)) then (print("\\mbox{ERROR: stack_matrix_disp requires lmxchar to be a string. }"), return("")),
+ parens: sublist(stack_matrix_pairs, lambda([ex], is(first(ex)=lmxchar))),
+ if emptyp(parens) then (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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))
+)$
+
+/* ********************************************************************* */
+/* 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(
+ ex: detexcolor(ex),
+ ex: make_displaydpvalue(ex),
+ ex: make_displayscivalue(ex),
+ if not(stack_disp_control_structurep(ex)) then
+ ex: unary_minus_sort(opsubst("*", stackunits, ex)),
+ ex: destackvector(ex),
+ return(string(ex))
+)$
+
+/* ********************************** */
+/* 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: concat(fb, "stack_trans('", key, "'", exprs, "); !NEWLINE!"),
+ return(str)
+)$
+
+/* Separate notes with puncutation, to enable clearer reading
+ and the possibility to split them. */
+StackAddNote(exnote, 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)]$
+
+/* ********************************************************* */
+/* Turns answertest output to a STACK return object string */
+/* */
+/* ex[1] = validity should be true/false */
+/* ex[2] = result should be true/false, */
+/* ex[3] = feedback, a string */
+/* ex[4] = answernote, is for teacher stats */
+/* */
+/* ********************************************************* */
+
+StackReturn(ex) := block([str],
+ if not(listp(ex)) then
+ (print("StackReturn failed: argument not a list: "), print(string(ex)), return("")),
+ if length(ex)#4 then
+ (print("StackReturn failed: argument wrong length: "), print(string(ex)), return("")),
+ print(" ], valid = [ "),
+ if ex[1] then print(1) else print(0),
+ print(" ], answernote = [ "),
+ print(ex[3]),
+ print(" ], feedback = [ "),
+ print(ex[4]),
+ return(ex[2])
+)$
+
+/* 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, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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. */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms. */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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"))),
+ /* Check if the student's answer is the same type as the Teacher's. */
+ SameType:ATSameTypefun(expr, TAns),
+ if SameType[2]#true then print(SameType[4]),
+ /* 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, ForbidFloats, 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 return(false),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* 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 */
+ if ForbidFloats and anyfloatex(expr) then
+ print(StackAddFeedback("", "Illegal_floats")),
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* The +- operator may only appear once. */
+ if ev(count_op(expr, "+-"), simp)>1 then
+ print(StackAddFeedback("", "Too_many+-")),
+ /* 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)
+)$
+
+/* These functions convert all variables in an expression to products of single letter variable names. */
+stack_singlevar_make_helper(ex) := block([s],
+ s: maplist(eval_string, charlist(string(ex))),
+ apply("*", s)
+)$
+
+stack_singlevar_make(ex) := block([vars, subs],
+ vars: sublist(listofvars(ex), lambda([ex], if slength(string(ex))>1 then true else false)),
+ if emptyp(vars) then return(ex),
+ vars:maplist(lambda([ex], ex=stack_singlevar_make_helper(ex)), vars),
+ /* We only need to use associtativity of "*", not "+", but we have to do it over the whole expression. */
+ STACK_assoc(sublis(vars, ex), ["*"])
+)$
+
+/* 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
+ (print(concat("Plot error: Can't create a plot with more than one variable, whereas you have: \\(",string(lvs),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /*********************/
+ /* 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ /*******************/
+ /* 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
+ (print(concat("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)")),
+ return("<center>[Empty plot]</center>")),
+ /********************************************/
+ /* 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='", 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"))]),
+
+ SA:sort(float(listify(SA))),
+ SB:sort(float(listify(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([Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ 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 not(integerp(nsf) and integerp(asf)) 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. */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ SA:SAA[1],
+ if (not(floatnump(SA)) and not(integerp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* 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 not(is(sign(SA)=sign(SB))) 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.
+ This changes 1.5 -> 2.0 (2.s.f). */
+ SB:significantfigures(SB, nsf),
+ /* Puts Teacher's answer 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,
+ 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)
+)$
+
+/* ********************************** */
+/* 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 */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ SB:errcatch(ev(SB, simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ SB:SB[1],
+ /* 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, eg 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([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 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 an equation? */
+ /* Don't use logic_edgep(SB) here, as this include "true" and "false". A teacher should use all/none if they mean equations. */
+ if (equationp(SB) or SB = all or SB = none) then
+ /* But the student can also use true/false here. Note the concious asymetry. */
+ if (equationp(SA) or logic_edgep(SA)) then
+ return(ATEquation(SA, SB))
+ else if equationp(SB) and not equationp(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, "+-"))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ /* Are we dealing with an inequality? */
+ if inequalityp(SB) then
+ if inequalityp(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)),
+ /* 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)
+)$
+
+/* 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]),
+ SA1:args(SA), SAd1:second(SA1),
+ SB1:args(SB), SBd1:second(SB1),
+ /* 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]),
+ FeedBack:StackAddFeedback("", "ATMatrix_wrongsz", stack_disp(SBr, "i"), stack_disp(SBc, "i"), stack_disp(SAr, "i"), stack_disp(SAc, "i")),
+ if (SAr#SBr) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_rows"), FeedBack]),
+ if (SAc#SBc) then
+ return([true, false, StackAddNote("", "ATMatrix_wrongsz_columns"), FeedBack]),
+ FeedBack:"",
+ /* 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, str, SAl, SBl, ZM],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Get sizes of matrices */
+ SAl:cardinality(SA),
+ SBl:cardinality(SB),
+ FeedBack:StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i")),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
+ FeedBack:"",
+ /* Check they are equal */
+ SA:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong ? */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "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],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Turn on simplification and error catch */
+ SAsimp:errcatch(ev(SA, simp, nouns)),
+ if is(SAsimp = [STACKERROR]) then return([false, false, StackAddNote("", "ATSets_STACKERROR_SAns"), ""]),
+ SAsimp:SAsimp[1],
+ SBsimp:errcatch(ev(SB, simp, nouns)),
+ if is(SBsimp = [STACKERROR]) then return([false, false, StackAddNote("", "ATSets_STACKERROR_TAns"), ""]),
+ SBsimp:SBsimp[1],
+ 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")),
+
+ /* 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])
+)$
+
+/* 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,"+-")=1), simp) then SA:pm_replace(SA),
+ if ev(is(count_op(SB,"+-")=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, "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, "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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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 */
+ 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"),""]),
+
+ /* 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 not is(ev(setify(listofvars(S1)),simp)=ev(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, ""]) else
+ 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,""]) else
+ if op(SB) = "+" then return(irred_Q(SB, SO)) else
+ 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: StackReturn */
+/* 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:StackAddFeedback("",""), 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"), ""]),
+
+ 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:true, 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"),""]),
+
+ /* 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 algebraic_equivalence(diff(SA,v),int(SB,v)) 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("")
+)$
+
+/* 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:2019090200$
diff --git a/stack/2019090200/maxima/stackreporting.mac b/stack/2019090200/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93
--- /dev/null
+++ b/stack/2019090200/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(
+ print("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/2019090200/maxima/stackstrings.mac b/stack/2019090200/maxima/stackstrings.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d26cae12094dfab583e57b95802aef10af053e11
--- /dev/null
+++ b/stack/2019090200/maxima/stackstrings.mac
@@ -0,0 +1,236 @@
+/* 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 withing 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) := listp(x) and is(length(x)>0) and is(x[1]="stack_map")$
+/* might as we be called stackmapp() but that sounds odd. */
+stackmapp(x) := is_stackmap(x)$
+
+stackmap_get(m, k) := block([tmp, val],
+ val:und,
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if (not is(tmp="stack_map")) and is(tmp[1]=k) then (val:tmp[2],return(tmp[2])),
+ return(val)
+)$
+
+stackmap_set(m, k, v) := block([tmp, found, r],
+ found: false,
+ r: ["stack_map"],
+ /* If we are given anything else than a map as the map we make a new map. */
+ if not is_stackmap(m) then return(append(r,[[k,v]])),
+ for tmp in m do if not is(tmp="stack_map") then (if is(tmp[1]=k) then (r:append(r,[[k,v]]),found:true) else r:append(r,[tmp])),
+ if not found then r:append(r,[[k,v]]),
+ return(r)
+)$
+
+stackmap_unset(m, k) := block([tmp, r],
+ r: ["stack_map"],
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then (if not is(tmp[1]=k) then r:append(r,[tmp])),
+ return(r)
+)$
+
+stackmap_keys(m) := block([tmp, r],
+ r: [], /* Might as well be a set but then we would lose the direct match to the values list... */
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then r:append(r,[tmp[1]]),
+ return(r)
+)$
+
+stackmap_values(m) := block([tmp, r],
+ r: [],
+ if not is_stackmap(m) then return(und),
+ for tmp in m do if not is(tmp="stack_map") then r:append(r,[tmp[2]]),
+ return(r)
+)$
+
+stackmap_has_key(m, k) := block([tmp, found],
+ found: false,
+ if not is_stackmap(m) then return(false),
+ for tmp in m do if not is(tmp="stack_map") then (if is(tmp[1]=k) then found:true),
+ 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) then r:sconcat("[",simplode(makelist(stackjson_stringify(x),x,obj),","),"]")
+ 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)
+)$
diff --git a/stack/2019090200/maxima/stacktex.lisp b/stack/2019090200/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7a7c8d8dd140d2b215bc15e9584a42f2685a2b99
--- /dev/null
+++ b/stack/2019090200/maxima/stacktex.lisp
@@ -0,0 +1,353 @@
+;; 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 $+-) :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))))
+
+;; Sort out binding power of %union to display correctly.
+;; tex-support is defined in to_poly_solve_extra.lisp.
+(defprop $%union 115. tex-rbp)
+
+
+;; 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))));
diff --git a/stack/2019090200/maxima/stacktex40.lisp b/stack/2019090200/maxima/stacktex40.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2f688179b2c7d0573e3db8a3caef343746f7fbae
--- /dev/null
+++ b/stack/2019090200/maxima/stacktex40.lisp
@@ -0,0 +1,91 @@
+;; 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 $+-) :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)))
+
+;; *************************************************************************************************
+;; 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) (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/2019090200/maxima/stackunits.mac b/stack/2019090200/maxima/stackunits.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d34c09137915fe6c308400e0b9ed4f5bb9014cff
--- /dev/null
+++ b/stack/2019090200/maxima/stackunits.mac
@@ -0,0 +1,578 @@
+/* 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)="+-") 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(
+ print("fracdisp argument to stack_validate_units 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)="+-")) 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 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. */
+ATUnitsSigFigs(SA, SB, SO) := ATUnitsFun(SA, SB, SO, false, "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, SAU1, SBU1, ol, ret, ret1, ret2],
+ validity:true, rawmk:true, fb:"", ansnote:"",
+ SAA:errcatch(ev(SA, simp, nouns)),
+ if (is_simp(SAA = [STACKERROR]) or is_simp(SAA = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(SB, simp, nouns)),
+ if (is_simp(SBB = [STACKERROR]) or is_simp(SBB = [])) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(SO, simp, nouns)),
+ if (is_simp(SOO = [STACKERROR]) or is_simp(SOO = [])) 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 (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU)),
+
+ /* 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, ol])),
+ if (numtest = "SigFigs") then
+ ret1: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret1: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret1: ATNumRelative(SAU1, SBU1, ol)
+ 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]]),
+
+ /* 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),
+ SAU:stackunits_make(SA),
+ SBU:stackunits_make(SB),
+ if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU)),
+ /* Check the accuracy again, now we have converted. */
+ SAU1:ev(float(stack_units_nums(SAU)), simp),
+ SBU1:ev(float(stack_units_nums(SBU)), simp),
+ if (numtest = "SigFigs") then
+ ret2: ATNumSigFigs(SAU1, SBU1, ol)
+ else if (numtest = "Absolute") then
+ ret2: ATNumAbsolute(SAU1, SBU1, ol)
+ else if (numtest = "Relative") then
+ ret2: ATNumRelative(SAU1, SBU1, ol)
+ 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/2019090200/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2019090200/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d4e798fd0706ced74f70dd61ce6c9a3d2f943b85
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/unittests_load.mac b/stack/2019090200/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..072158a1c3ce7b06181b68fe7c37e507718f471b
--- /dev/null
+++ b/stack/2019090200/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/2019090200/maxima/utils.mac b/stack/2019090200/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..940f0fadcf9004fd103dfc8713dfb71d86ad3f35
--- /dev/null
+++ b/stack/2019090200/maxima/utils.mac
@@ -0,0 +1,115 @@
+/* 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)
+)$
+
+
+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/2020042000/maxima/assessment.mac b/stack/2020042000/maxima/assessment.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8568187cd50b1d852e0c7048280b365458372ad9
--- /dev/null
+++ b/stack/2020042000/maxima/assessment.mac
@@ -0,0 +1,2342 @@
+/* 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);
+
+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)="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)$
+
+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) = "and" then return(true),
+ if safe_op(ex) = "or" then return(true),
+ if safe_op(ex) = "not" 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", "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:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", 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)
+)$
+
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ return(rex)
+)$
+
+/****************************************************************/
+/* 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/2020042000/maxima/assessment.texi b/stack/2020042000/maxima/assessment.texi
new file mode 100644
index 0000000000000000000000000000000000000000..8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/casanswertest.mac b/stack/2020042000/maxima/casanswertest.mac
new file mode 100644
index 0000000000000000000000000000000000000000..b28d0f60ae7aafde26e3e2a3fbab9fd4ff8ee567
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/elementary.mac b/stack/2020042000/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..4a97fa232ad4aa9690e09f3d297ff2c09ddb9a64
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/errortostring.lisp b/stack/2020042000/maxima/errortostring.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..df6ba14adccbcc5a28edb087600b1cbbba22edbb
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/expandfeedback.mac b/stack/2020042000/maxima/expandfeedback.mac
new file mode 100644
index 0000000000000000000000000000000000000000..8d688ae5ed3877bd701e4a4d10b3d9585fbd9985
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/experimental.mac b/stack/2020042000/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..3ee1f9eb3e14988781dd85932ee68c0191abaf4b
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/inequalities.mac b/stack/2020042000/maxima/inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..be3f8c9b5904946a27f08a6b1835f361f928ab73
--- /dev/null
+++ b/stack/2020042000/maxima/inequalities.mac
@@ -0,0 +1,305 @@
+/* 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 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/2020042000/maxima/intervals.mac b/stack/2020042000/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..94a6db69343c25b78cd6bbf6b87e08fe59076e35
--- /dev/null
+++ b/stack/2020042000/maxima/intervals.mac
@@ -0,0 +1,1027 @@
+/* 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 intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V0.2 June 2017 */
+/* */
+/********************************************************************/
+
+/* 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
+ );
+*/
+
+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(Complement(b), simp),
+ if 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)],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(false),
+ 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 setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(all_listp(intervalp, args(ex))),
+ 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=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 atom(ex) then return(false),
+ if setp(ex) and ex={} then return(true),
+ if save_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)
+)$
+
+SimpleUnion(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 setp(A) then
+ (
+ if 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 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 setp(A) or atom(B) or 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:SimpleUnion( 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)
+ )
+ )
+ )
+ )
+ ),
+ if safe_op(Ans)="[" then Ans:apply(%union, Ans),
+ Ans
+ );
+
+
+/* Finds the intersection of two "simple" sets: */
+SimpleIntersect(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 Ans:{} elseif
+ atom(B) then Ans:{} elseif
+ setp(A) then
+ (
+ if setp(B) then
+ (
+ return(intersect(A,B))
+ )
+ else
+ (
+ 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:{}
+ )
+ )
+ elseif setp(B) then
+ (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do
+ (if inintervalp(Aset[i],A) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans:setAns ) else Ans:{}
+ ),
+ if ( not atom(A) and not atom(B) ) then
+ (
+ Args1:args(A),
+ Args2:args(B),
+
+ if (not atom(A) and not(op(A)=set) and not atom(B) and not(op(B)=set) ) 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:{},
+ 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
+ );
+
+SimpDisjointp(A,B) := if SimpleIntersect(A,B)={} then true else false;
+
+/* Given a *list* of disjoint intervals, returns the same intervals but in ascending order: */
+SortUnion(X) :=
+ block ( [A:X, Ans:[], x, n, i],
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ if ( first( A[i] ) < first( x ) ) then x:A[i],
+ i:i+1
+ ),
+ Ans:append( Ans, [x] ),
+ A:delete( x, A, 1 ),
+ n:n-1
+ ),
+ Ans
+ );
+
+/* Given a union of disjoint intervals, checks whether any intervals are connected, and if so, joins them up and returns the ammended union: */
+ConnectIntervals(X):=
+ block ( [Ans, n, x, y, i:1],
+
+ if not(op(X)=%union) then error("ConnectIntervals requires a %union of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ if last( Ans[i] ) >= first( Ans[i+1] ) then
+ (
+ x:SimpleUnion( Ans[i], Ans[i+1] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[i+1], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ n:n-1,
+ i:i-1
+ )
+ ),
+ 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: */
+TidyUnion(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),
+
+ if (not (op(X)=%union or op(X)="[") ) then Ans:X
+ else
+ (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<n+1 do
+ (
+ if ( setp(A[i]) ) then
+ (
+ setpart:union( setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ )
+ else if ( trivialintervalp(A[i]) ) then
+ (
+ A:delete( A[i], A, 1 ),
+ i:i-1,
+ n:n-1
+ ),
+ i:i+1
+ ),
+ A:SortUnion(A),
+ if is(length(A)>1) then
+ A:ConnectIntervals(apply(%union, A)),
+ if length(setpart)>0 then A:append( args(A), [setpart] ),
+ if is(length(A)=1) then
+ A:first(A),
+ Ans:A
+ ),
+ Ans
+ )$
+
+/* Finds the union of any two sets: */
+Union(X, Y) :=
+ block ( [A, B, Ans:[], Joined:[], sets:{}, add, temp, x, y, m, n, k, i:1, j:1, f:1],
+ if atom(X) then Ans:Y
+ elseif atom(Y) then Ans:X
+ else
+ (
+
+ A:X,
+ if op(X)=%union then A:args(X),
+ B:Y,
+ if op(Y)=%union then B:args(Y),
+
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleUnion(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:Union(A,B) )
+ else
+ (
+ while i<(m+1)do
+ (
+ if op( A[i] ) = set then
+ (
+ sets:SimpleUnion( sets , A[i] ),
+ A:delete( A[i] , A , 1 ),
+ i:i-1,
+ m:m-1
+ ),
+ i:i+1
+ ),
+ i:1,
+ while j<(n+1)do
+ (
+ if op( B[j] ) = set then
+ (
+ sets:SimpleUnion( sets , B[j] ),
+ B:delete( B[j] , B , 1 ),
+ j:j-1,
+ n:n-1
+ ),
+ j:j+1
+ ),
+ j:1,
+ temp:Ans,
+
+ Joined:append(A,B),
+ Joined:JoinedUnion(Joined),
+ temp:append(temp,Joined),
+
+ if length(sets)>0 then
+ (
+ sets:listify(sets),
+ m:length(temp),
+ n:length(sets),
+ while j<(n+1) do
+ (
+ while i<(m+1) do
+ (
+ x:first( temp[i] ),
+ y:last( temp[i] ),
+ if inintervalp( sets[j], temp[i] ) then
+ (
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ )
+ elseif ( sets[j]=x or sets[j]=y ) then
+ (
+ temp[i]:Union( temp[i], { sets[j] } ) ,
+ sets:delete( sets[j], sets, 1 ),
+ n:n-1,
+ j:j-1,
+ i:m+1
+ ),
+ i:i+1
+ ),
+ i:1,
+ j:j+1
+ ),
+ j:1,
+ if length(sets)>0 then
+ (
+ sets:setify(sets),
+ temp:cons(sets,temp)
+ )
+ ),
+ if length(temp)=1 then temp:temp[1],
+ Ans:temp
+ )
+ ),
+ Ans:TidyUnion(Ans)
+ ),
+
+ Ans
+ );
+
+/* When given a union of intervals, this function simplifies the union by joining up any connected intervals: */
+JoinedUnion(X) :=
+ block ( [A, nextA:[], disjoint:[], temp, Ans:[], n, i, j, alldisjoint:false, Joined:[] ],
+
+ A:X,
+ if op(A)=%union then A:args(A),
+ while alldisjoint = false do
+ (
+ alldisjoint:true,
+ n:length(A),
+ disjoint:[],
+ i:1,
+ while i<n+1 do
+ (
+ disjoint: append(disjoint, [true] ),
+ i:i+1
+ ),
+ i:1,
+ while i<n do
+ (
+ j:i+1,
+ while j<n+1 do
+ (
+ if ( SimpDisjointp( A[i], A[j] ) ) then
+ (
+ if disjoint[j] = true then
+ (
+ nextA:delete( A[j], nextA, 1),
+ nextA:append(nextA, [ A[j] ] )
+ )
+ )
+ else (
+ nextA:delete( A[i], nextA, 1),
+ nextA:delete( A[j], nextA, 1),
+ temp:SimpleUnion( A[i], A[j] ),
+ if ( not op(temp) = "[" ) then temp:[temp],
+ nextA:append(nextA, temp ),
+ disjoint[i]:false,
+ disjoint[j]:false,
+ alldisjoint:false
+ ),
+ j:j+1
+ ),
+ if disjoint[i] = true then
+ (
+ nextA:delete( A[i], nextA, 1 ),
+ nextA:append(nextA, [ A[i] ] )
+ ),
+ i:i+1
+ ),
+ if alldisjoint = false then A:nextA,
+ nextA:[]
+ ),
+ Ans:A,
+ Ans
+ );
+
+Intersection(X,Y) :=
+ block ([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if is(A=all) then return(B)
+ elseif is(B=all) then return(A)
+ elseif atom(A) then Ans:{}
+ elseif atom(B) then Ans:{}
+ else
+ (
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if ( ( not op(A)="[" ) and ( not op(B)="[" ) ) then Ans:SimpleIntersect(A,B)
+ else
+ (
+ if ( not op(A)="[" ) then (temp:[], A:cons(A,temp) ),
+ if ( not op(B)="[" ) then (temp:[], B:cons(B,temp) )
+ ),
+
+ if ( ( op(A)="[" ) and ( op(B)="[" ) ) then
+ (
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (A:A[1], B:B[1], Ans:SimpleIntersect(A,B) )
+ else
+ (
+ while i<m+1 do
+ (
+ while j<n+1 do
+ (
+ temp:SimpleIntersect( A[i], B[j] ),
+ if not atom(temp) then
+ (
+ Ans:append( Ans, [temp] )
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ )
+ ),
+ if (not atom(Ans)) and op(Ans) = "[" then
+ (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ )
+ ),
+ Ans:TidyUnion(Ans),
+ Ans
+ );
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+ListIntersect(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:Intersection(Ans,A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+OrderPoints(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:TidyUnion(A),
+ if op( last(A) ) = set 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
+ );
+
+
+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( Ans:oo(-inf,inf) ),
+ if not (op(A) = "[" or op(A)=%union) then
+ (
+ if op(A)=set then Ans:SetComplement(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:OrderPoints(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(ListIntersect(maplist(lambda([ex2], TidyUnion(Complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ else if listp(Ans) then
+ Ans:apply(%union, Ans)
+ ),
+
+ Ans
+ );
+
+SetComplement(X):=
+ block ( [A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("SetComplement 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("%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), realsetp), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realsetp(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, realsetp), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realsetp(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([TidyUnion(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([ListIntersect(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(realsetp(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:ListIntersect(ex2),
+ ex2
+)$
diff --git a/stack/2020042000/maxima/noun_arith.lisp b/stack/2020042000/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b5b209adabcebeb71f4d5b15e256aaf35fb904d1
--- /dev/null
+++ b/stack/2020042000/maxima/noun_arith.lisp
@@ -0,0 +1,52 @@
+;; 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)
+
+;; Chris Sangwin 3 Feb 2016.
+
+(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)
+
+;; Chris Sangwin 29 Sept 2017.
+
+(defprop mnot tex-prefix tex)
+;;(defprop mnot ("\\neg ") texsym)
+(defprop mnot ("{\\rm !NOT!}") texsym)
\ No newline at end of file
diff --git a/stack/2020042000/maxima/rtest_assessment_simpboth.mac b/stack/2020042000/maxima/rtest_assessment_simpboth.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bc02f607f7cb9219dbadde904a5e70c875460a14
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/rtest_assessment_simpfalse.mac b/stack/2020042000/maxima/rtest_assessment_simpfalse.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/rtest_assessment_simptrue.mac b/stack/2020042000/maxima/rtest_assessment_simptrue.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6f71fbf308f39067a419f103f2f6e41a93f1d725
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/rtest_elementary.mac b/stack/2020042000/maxima/rtest_elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f0034a8ad8f64a7b28d9819eeaf80483078839bf
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/rtest_experimental.mac b/stack/2020042000/maxima/rtest_experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/stack/2020042000/maxima/rtest_inequalities.mac b/stack/2020042000/maxima/rtest_inequalities.mac
new file mode 100644
index 0000000000000000000000000000000000000000..2498d27574c6e7dc113cb932b6f23b37ce4a1214
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/rtest_intervals.mac b/stack/2020042000/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..d98bb969451810e6c345a7c556f536bb7fa17957
--- /dev/null
+++ b/stack/2020042000/maxima/rtest_intervals.mac
@@ -0,0 +1,77 @@
+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))$
+
+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$
+
+Intersection(%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))$
+
+ListIntersect([%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))$
+
+Complement(%union(oo(0,1),oo(2,3),oo(3,inf)));
+%union(cc(1,2),{3},oc(-inf,0))$
diff --git a/stack/2020042000/maxima/sandbox.wxm b/stack/2020042000/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..bd88b25e6a280ec615a7d72c454bdd362988340a
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/stackmaxima.mac b/stack/2020042000/maxima/stackmaxima.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e486a96548f14314b3b4e76d6de5c223d232ef45
--- /dev/null
+++ b/stack/2020042000/maxima/stackmaxima.mac
@@ -0,0 +1,3060 @@
+/* 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(
+ 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"); */
+
+/* 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("not", "{\\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("not", "\\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> ", 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 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 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 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)),
+ /* 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)
+)$
+
+/* 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, str, 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:map(ineqprepare, map(trigreduce, SA)),
+ SB:map(ineqprepare, map(trigreduce, SB)),
+ if (subsetp(SA, SB) and subsetp(SB, SA)) then
+ return([true, true, AnswerNote, FeedBack]),
+ /* Can we give feedback on which are wrong ? */
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "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")),
+
+ /* 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])
+)$
+
+/* 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)
+)$
+
+
+/**********************************************/
+/* */
+/* 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("")
+)$
+
+/* 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:2020042000$
diff --git a/stack/2020042000/maxima/stackreporting.mac b/stack/2020042000/maxima/stackreporting.mac
new file mode 100644
index 0000000000000000000000000000000000000000..14f9dd717a668bad6d7ff1effbf97aac8d58f67e
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/stackstrings.mac b/stack/2020042000/maxima/stackstrings.mac
new file mode 100644
index 0000000000000000000000000000000000000000..6d859765224d21c3758b39a9ab8dc4d0fbffee14
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/stacktex.lisp b/stack/2020042000/maxima/stacktex.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e5e0e120755882d4af215b5d05245aeb04174720
--- /dev/null
+++ b/stack/2020042000/maxima/stacktex.lisp
@@ -0,0 +1,423 @@
+;; 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))))
+
+;; Sort out binding power of %union to display correctly.
+;; tex-support is defined in to_poly_solve_extra.lisp.
+(defprop $%union 115. tex-rbp)
+
+
+;; *************************************************************************************************
+;; 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
+)
+
diff --git a/stack/2020042000/maxima/stacktex40.lisp b/stack/2020042000/maxima/stacktex40.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9a7c45efe1fe2cce67cfb8368bde24c89b184936
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/stackunits.mac b/stack/2020042000/maxima/stackunits.mac
new file mode 100644
index 0000000000000000000000000000000000000000..59062c9922ac0ad7808ba1d031b74752a29d2529
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/to_poly_solve_extra_5.38.1.lisp b/stack/2020042000/maxima/to_poly_solve_extra_5.38.1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d4e798fd0706ced74f70dd61ce6c9a3d2f943b85
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/unittests_load.mac b/stack/2020042000/maxima/unittests_load.mac
new file mode 100644
index 0000000000000000000000000000000000000000..072158a1c3ce7b06181b68fe7c37e507718f471b
--- /dev/null
+++ b/stack/2020042000/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/2020042000/maxima/utils.mac b/stack/2020042000/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..ea52d5328d3627591f16e3ea6419469b765a8b67
--- /dev/null
+++ b/stack/2020042000/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_version b/stack_version
deleted file mode 100644
index 906cd54982f69d26966eb1704a71ebe1d9c6bb88..0000000000000000000000000000000000000000
--- a/stack_version
+++ /dev/null
@@ -1,5 +0,0 @@
-stack-2019090200 12439ff1a3a16280e115ce1fab4a23b985c90509
-stack-2018030600 12439ff1a3a16280e115ce1fab4a23b985c90509
-stack-2018030500 12439ff1a3a16280e115ce1fab4a23b985c90509
-stack-2017121800 12439ff1a3a16280e115ce1fab4a23b985c90509
-stack-2014083000 9a42ef87ef6a8ae06e8e60bb2eacb7490ba166d3
diff --git a/versions b/versions
new file mode 100644
index 0000000000000000000000000000000000000000..71b947cd83903e1803e6fbb453c5536010fab6bc
--- /dev/null
+++ b/versions
@@ -0,0 +1,7 @@
+# maxima,sbcl,stack
+5.41.0 2.0.2 2014083000
+5.41.0 2.0.2 2017121800
+5.41.0 2.0.2 2018030500
+5.41.0 2.0.2 2018080600
+5.41.0 2.0.2 2019090200
+5.41.0 2.0.2 2020042000