diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index a62f60c31713dbcfd8f52882352a1cc5bdc2997e..e065125da9c1f186a33ff2b6838e935d1d498032 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -62,13 +62,16 @@ test_maxima:
when: manual
tags:
- docker
- # the tests do not work perfectly for now because of
- # sbcl issues
+ # the tests do not work perfectly for older versions
+ # because of sbcl issues
allow_failure: true
parallel:
matrix:
+ - TEST_VERSION: "2023102700"
+ QSTACK_VERSION: "v4.4.6"
+ MOODLE_BRANCH: "MOODLE_400_STABLE"
- TEST_VERSION: "2023072101"
- QSTACK_VERSION: "v4.4.4"
+ QSTACK_VERSION: "v4.4.5"
MOODLE_BRANCH: "MOODLE_400_STABLE"
- TEST_VERSION: "2023060500"
QSTACK_VERSION: "v4.4.4"
diff --git a/README.md b/README.md
index adb22ac6e991457c0367254d9467d6254e091bc2..92af1d92266e2af40b787ef22ec33f75c56b02d0 100644
--- a/README.md
+++ b/README.md
@@ -70,7 +70,6 @@ What Stackmaxima version do I need?
| Ilias Stack Version | Moodle Stack Version | Stackmaxima version | Included Maxima version |
| ------------------- | -------------------- | ------------------- | ----------------------- |
-| `5.3`, `5.4` | - | 2017121800 | 5.41.0 |
| - | `4.2.1` | 2018080600 | 5.41.0 |
| `6`, `7` | `4.2.2a` | 2019090200 | 5.41.0 |
| - | `4.3.1` | 2020042000 | 5.41.0 |
@@ -88,6 +87,7 @@ What Stackmaxima version do I need?
| - | `4.4.3` | 2023052400 | 5.44.0 |
| - | `4.4.4` | 2023060500 | 5.44.0 |
| - | `4.4.5` | 2023072101 | 5.44.0 |
+| - | `4.4.6` | 2023102700 | 5.44.0 |
Environment Variables
diff --git a/docker-compose.yml b/docker-compose.yml
index 0c0d0195c5c0f3d9cafb5b0413ff8a1f52f7efac..e53866ddbb6028b2de1b8214f430db273aaf3331 100644
--- a/docker-compose.yml
+++ b/docker-compose.yml
@@ -1,7 +1,7 @@
version: "3.3"
services:
maxima:
- image: mathinstitut/goemaxima:${STACKMAXIMA_VERSION:-2023072101}-latest
+ image: mathinstitut/goemaxima:${STACKMAXIMA_VERSION:-2023102700}-latest
ports:
- 0.0.0.0:8080:8080
tmpfs:
diff --git a/stack/2017121800/maxima/arccos.lisp b/stack/2017121800/maxima/arccos.lisp
deleted file mode 100644
index 963ff6b45f83923546f7163cc973266c91102e7e..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/arccos.lisp
+++ /dev/null
@@ -1,51 +0,0 @@
-(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/complexi.lisp b/stack/2017121800/maxima/complexi.lisp
deleted file mode 100644
index 8be0972956d17463313be86ea1bd76f1b9552cbb..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/complexi.lisp
+++ /dev/null
@@ -1,10 +0,0 @@
-;; 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
deleted file mode 100644
index 1fdfd5b91a8993b84fc72fd9f39114151c8dd4ce..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/complexj.lisp
+++ /dev/null
@@ -1,10 +0,0 @@
-;; 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
deleted file mode 100644
index 7cdb2e2d0c69d196c7ae93ea9c9f2740ece76b59..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/cos-1.lisp
+++ /dev/null
@@ -1,51 +0,0 @@
-(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
deleted file mode 100644
index 77cb7ddc99b1fb2410361c1cefb654b41cc414ed..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/elementary.mac
+++ /dev/null
@@ -1,521 +0,0 @@
-/* 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/experimental.mac b/stack/2017121800/maxima/experimental.mac
deleted file mode 100644
index 98afe06e41c2d99210e1ca9301fcd43e1b447811..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/experimental.mac
+++ /dev/null
@@ -1,175 +0,0 @@
-/* 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/intervals.mac b/stack/2017121800/maxima/intervals.mac
deleted file mode 100644
index 0dc6c5a7f92aa4cedde0a85a49eb5febc651780f..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/intervals.mac
+++ /dev/null
@@ -1,1030 +0,0 @@
-/* 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
deleted file mode 100644
index 7671dad91e31b7c9b9caf64c27e3891e2d73e4c0..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/mathml.lisp
+++ /dev/null
@@ -1,762 +0,0 @@
-(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
deleted file mode 100644
index 8299d076a99df596824a75e72ac37c9cff2759dc..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/multiply_blank.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-;; 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
deleted file mode 100644
index ec0052c83f44c454a238de0e579d79121ebf2f3b..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/multiply_cross.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-;; 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
deleted file mode 100644
index fb7cb69891f68486972dd35d406fe5a2b79fe1f8..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/multiply_dot.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-;; 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
deleted file mode 100644
index 3ffda4a9b0b67068f7d0b8ba9291b3b35212fbf1..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/noun_arith.lisp
+++ /dev/null
@@ -1,47 +0,0 @@
-;; 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_elementary.mac b/stack/2017121800/maxima/rtest_elementary.mac
deleted file mode 100644
index f0034a8ad8f64a7b28d9819eeaf80483078839bf..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/rtest_elementary.mac
+++ /dev/null
@@ -1,179 +0,0 @@
-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_intervals.mac b/stack/2017121800/maxima/rtest_intervals.mac
deleted file mode 100644
index 2e72d77091c1fb56eba98f1d12cbbc7a692ced3b..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/rtest_intervals.mac
+++ /dev/null
@@ -1,62 +0,0 @@
-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
deleted file mode 100644
index 8162b8c7b20469febe2605e9c84020b5446d960a..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/sandbox.wxm
+++ /dev/null
@@ -1,67 +0,0 @@
-/* [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/utils.mac b/stack/2017121800/maxima/utils.mac
deleted file mode 100644
index 940f0fadcf9004fd103dfc8713dfb71d86ad3f35..0000000000000000000000000000000000000000
--- a/stack/2017121800/maxima/utils.mac
+++ /dev/null
@@ -1,115 +0,0 @@
-/* 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/2017121800/maximalocal.mac.template b/stack/2017121800/maximalocal.mac.template
deleted file mode 100644
index d84b9bb5899151d44862c81accc99565ebda0a75..0000000000000000000000000000000000000000
--- a/stack/2017121800/maximalocal.mac.template
+++ /dev/null
@@ -1,41 +0,0 @@
-/* ***********************************************************************/
-/* This file is automatically generated at installation time. */
-/* The purpose is to transfer configuration settings to Maxima. */
-/* Hence, you should not edit this file. Edit your configuration. */
-/* This file is regularly overwritten, so your changes will be lost. */
-/* ***********************************************************************/
-
-/* File generated on July 29, 2020, 4:26 pm */
-
-/* Add the location to Maxima's search path */
-file_search_maxima:append( [sconcat("${LIB}/###.{mac,mc}")] , file_search_maxima)$
-file_search_lisp:append( [sconcat("${LIB}/###.{lisp}")] , file_search_lisp)$
-file_search_maxima:append( [sconcat("${LOG}/###.{mac,mc}")] , file_search_maxima)$
-file_search_lisp:append( [sconcat("${LOG}/###.{lisp}")] , file_search_lisp)$
-
-STACK_SETUP(ex):=block(
- MAXIMA_VERSION_NUM_EXPECTED:41,
- MAXIMA_PLATFORM:"server",
- maxima_tempdir:"${TMP}/",
- IMAGE_DIR:"${PLOT}/",
- PLOT_SIZE:[450,300],
- PLOT_TERMINAL:"svg",
- PLOT_TERM_OPT:"dynamic font \",11\" linewidth 1.2",
- DEL_CMD:"rm",
- GNUPLOT_CMD:"gnuplot",
- MAXIMA_VERSION_EXPECTED:"5.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", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mu ", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm"],
- 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", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\Omega", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm"],
- 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", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm{{}^}", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm", "\\mathrm"],
- true)$
-/* Load the main libraries. */
-/* load("stackmaxima.mac")$ */
-
diff --git a/stack/2017121800/maxima/assessment.mac b/stack/2023102700/maxima/assessment.mac
similarity index 61%
rename from stack/2017121800/maxima/assessment.mac
rename to stack/2023102700/maxima/assessment.mac
index 7158924091ec37f451b4759e7c5bf2b15119d930..7d635ac5c073aea11941ee04b9e672e015d49725 100644
--- a/stack/2017121800/maxima/assessment.mac
+++ b/stack/2023102700/maxima/assessment.mac
@@ -1,6 +1,6 @@
/* Author Chris Sangwin
University of Edinburgh
- Copyright (C) 2015 Chris Sangwin
+ 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.
@@ -13,17 +13,17 @@
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 */
+/* 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))$
+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 */
@@ -45,6 +45,12 @@ if not(?functionp('rempart)) then load(functs);
/* op(ex) is unsafe on atoms: this is a fix. */
/* This function always returns a string. */
safe_op(ex) := block([st],
+ /* Subtle changes in mapatom, in Maxima 5.42.2, with simp:false. */
+ if atom(ex) then return(""),
+ if op(ex) = "-" then return("-"),
+ if op(ex) = "/" then return("/"),
+ if op(ex) = "integrate" then return("int"),
+ /* Catch a subscript. */
if mapatom(ex) then return(""),
if stringp(op(ex)) then return(op(ex)),
st:string(op(ex)),
@@ -86,6 +92,36 @@ poly_equate_coeffs(p1,p2,v) := block([deg,kloop,cl],
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? */
@@ -99,11 +135,42 @@ op_usedp(ex, opused) := block(
apply("or", maplist(lambda([ex2], op_usedp(ex2, opused)), args(ex)))
)$
-/* Count the occurances of v in ex. */
-count_occurances(ex, v):=block(
+/* Count the occurances of v in ex.
+ v can be a string (for safe_op) or atom.
+*/
+count_occurances(ex, v):=block([isop],
if ex=v then return(1),
if atom(ex) then return(0),
- apply("+", map(lambda([ex2], count_occurances(ex2, v)), args(ex)))
+ isop:0,
+ if safe_op(ex)=v then isop:1,
+ isop+apply("+", map(lambda([ex2], count_occurances(ex2, v)), args(ex)))
+)$
+/* Recurse over a whole expression tree to see if the predicate is satisfied anywhere. */
+recurse_predp(ex, pr):= block(
+ if mapatom(ex) then return(pr(ex)),
+ pr(ex) or apply("or", map(lambda([ex2], recurse_predp(ex2, pr)), args(ex)))
+);
+
+/* ********************************************** */
+/* Functions for selecting parts of an expression */
+/* ********************************************** */
+
+/* This function selects, and displays, parts of an expression for which the predicate is true. */
+select(p1, ex) := block(
+ if p1(ex) then return(disp_select(ex)),
+ if atom(ex) then return(ex),
+ apply(op(ex), map(lambda([ex2], select(p1, ex2)), args(ex)))
+)$
+
+/* This function applys the function f1 to parts already selected by the function select. */
+select_apply([ex1]) := block([f1, ex, s1],
+ f1:first(ex1),
+ ex:second(ex1),
+ s1:true,
+ if ev(is(length(ex1)>2), simp) then s1:third(ex1),
+ if atom(ex) then return(ex),
+ if safe_op(ex)="disp_select" then if s1 then return(f1(first(args(ex)))) else return(f1(ex)),
+ apply(op(ex), map(lambda([ex2], select_apply(f1, ex2, s1)), args(ex)))
)$
/* ********************************** */
@@ -114,10 +181,10 @@ count_occurances(ex, v):=block(
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"$
+all_listp(p, l) := if listp(l) then apply("and", maplist(p, l)) else error("all_listp expects its argument to be a list.")$
/* any_listp(p,l) true if all elements of l satisfy p. */
-any_listp(p, l) := if listp(l) then ret:apply("or", maplist(p, l)) else ret:"fail"$
+any_listp(p, l) := if listp(l) then apply("or", maplist(p, l)) else error("any_listp expects its argument to be a list.")$
/* Returns true iff a and b are lists (not necessarily same length) with one or more common elements, false o/w. */
listsoverlap(a, b) := not(emptyp(intersection(setify(a), setify(b))))$
@@ -125,6 +192,25 @@ listsoverlap(a, b) := not(emptyp(intersection(setify(a), setify(b))))$
/* Returns true iff a and b are lists (not necessarily same length) and contain the common element v */
listscontain(a, b, v) := elementp(v, intersection(setify(a), setify(b)))$
+/* Removes the first occurance of ex from the list l. */
+removeonce(ex, l) := block(
+ if listp(l)#true or emptyp(l) then return([]),
+ if first(l)=ex then return(rest(l)),
+ append([first(l)], removeonce(ex,rest(l)))
+)$
+
+/* Remove any common elements from [l1,l2], with duplication. */
+list_cancel(ex) := block([l1, l2, l3],
+ l1:first(ex),
+ l2:second(ex),
+ if not(listp(l1)) or not(listp(l2)) then error("Arguments of list_cancel must be lists."),
+ if emptyp(l1) then return([l1, l2]),
+ if emptyp(l2) then return([l1, l2]),
+ if element_listp(first(l2), l1) then return(list_cancel([removeonce(first(l2), l1), rest(l2)])),
+ l3:list_cancel([l1, rest(l2)]),
+ return([first(l3),append([first(l2)], second((l3)))])
+)$
+
/* This function applies the binary function zf to two lists a and b returning a list
[ zf(a[1],b[1]), zf(a[2],b[2]), ... ] zip_with quietly gives up when one of the list runs out of elements.
Actually, we can achieve some of this with map(zf, a, b) but this does not give up quietly
@@ -156,10 +242,35 @@ 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 */
/* ********************************** */
+/* It is very useful to know if we have a "variable". */
+variablep(ex) := atom(ex) and not(real_numberp(ex)) and not(ex=%i) and not(stringp(ex))$
+
/* Determines if we are using an equation. */
equationp(ex) := block(
if atom(ex) then return(false),
@@ -182,9 +293,10 @@ inequalityp(ex) := block(
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) then
- return (false),
+ 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)
);
@@ -195,6 +307,13 @@ polynomialpsimp(ex):= block([v],
polynomialp(ex, v)
)$
+calculusp(ex) := block(
+ if atom(ex) then return(false),
+ if "diff" = op(ex) or "noundiff" = op(ex) or "int" = op(ex) or "nounint" = op(ex) then return(true),
+ return(false)
+)$
+
+
/* This is to fix a bug in Maxima 5.38.1. */
safe_setp(ex) := setp(ex) or safe_op(ex) = "{"$
@@ -203,22 +322,24 @@ safe_setp(ex) := setp(ex) or safe_op(ex) = "{"$
/* ********************************** */
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.")
-)$
+/* Legacy reasons */
+alias(lg, logbase);
-logbasetex(ex) := block([n, b],
- [n, b]:args(ex),
+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(logbase, logbasetex);
+texput(lg, lgtex);
/* Use of radcan to give canonical form. */
-logbasesimp(n,b) := radcan(log(n)/log(b));
+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(
@@ -249,7 +370,7 @@ find_rationals(ex) := block(
/* 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],
@@ -271,6 +392,13 @@ simp_numberp(ex) := block(
false
)$
+simp_floatnump(ex) := block(
+ if floatnump(ex) then return(true),
+ if atom(ex) then return(false),
+ if op(ex)="-" and floatnump(first(args(ex))) then return(true),
+ false
+)$
+
simp_integerp(ex) := block(
if integerp(ex) then return(true),
if atom(ex) then return(false),
@@ -280,24 +408,122 @@ simp_integerp(ex) := block(
/* Do we have a rational number? */
rational_numberp(ex) := block(
+ if safe_op(ex)="-" then return(rational_numberp(first(ex))),
if safe_op(ex)="/" and simp_integerp(num(ex)) and simp_integerp(denom(ex)) then return(true),
return(false)
-);
+)$
/* Do we have a real number? */
/* Code taken from Stack_Test */
-real_numberp(ex):=
- block([keepfloat, trigexpand, logexpand],
+real_numberp(ex):= block([keepfloat, trigexpand, logexpand],
trigexpand:true,
logexpand:super,
keepfloat:true,
- ex:errcatch(ev(fullratsimp(ex), logbase=logbasesimp, simp)),
+ /* Using full ratsimp here makes this function unacceptably slow. */
+ ex:errcatch(ev(ex, lg=logbasesimp, simp)),
if ex=[] then return(false),
ex:ev(float(ex[1]),simp),
if listofvars(ex)#[] then return(false),
if floatnump(ex) then return(true) else return(false)
)$
+/* Do we have a complex number? */
+simp_complex_number_p(ex):= block([keepfloat, trigexpand, logexpand],
+ trigexpand:true,
+ logexpand:super,
+ keepfloat:true,
+ /* Using full ratsimp here makes this function unacceptably slow. */
+ ex:errcatch(ev(ex, lg=logbasesimp, simp)),
+ if ex=[] then return(false),
+ ex:ev(float(ex[1]),simp),
+ if listofvars(ex)#[] then return(false),
+ if floatnump(ex) then return(true),
+ if complex_number_p(ex) then return(true) else return(false)
+)$
+
+/* Do we have a real number, inf or -inf? */
+extended_real_numberp(ex) := block(
+ if (ex=inf or ex=-inf or ex=minf or ex=-minf) then return(true),
+ return(real_numberp(ex))
+)$
+
+/* Decide if we have a purely imaginary number. */
+imag_numberp(ex) := block(
+ ev(is(equal(ex, %i*imagpart(ex))), simp)
+)$
+
+/* Decide if a number is written in complex exponential form, r*%e^(%i*theta).
+ Needs simp:false. */
+complex_exponentialp(ex):=block([ex2],
+ /* Edge case of a real number! */
+ if ev(real_numberp(ex), simp) then return(true),
+ ex2:ex,
+ if safe_op(ex)="*" then
+ if not(is(real_numberp(first(args(ex))))) then
+ return(false)
+ else
+ ex2:second(args(ex)),
+ if safe_op(ex)="/" then
+ if not(is(real_numberp(second(args(ex))))) then
+ return(false)
+ else
+ ex2:first(args(ex)),
+ /* Case of r=1, which is not written, or stripped off by the above code. */
+ if safe_op(ex2)="^" then
+ if is(equal(first(args(ex2)),%e)) and is(imag_numberp(second(args(ex2)))) then
+ return(true),
+ if safe_op(ex2)="exp" and is(imag_numberp(first(args(ex2)))) then return(true),
+ return(false)
+)$
+
+polarform_simp(ex) := block([%_r, %_theta, %_pf, simp],
+ /* We can't return a meaningful value for arg(ex) so we just return 0. */
+ if is(ev(ex, simp)=0) then return(0),
+ /* It is a design choice to return a positive real number, rather than r*%e^0, or r*%e^(%i*0). */
+ if ev(real_numberp(ex) and ex>0, simp) then return(ex),
+ simp:false,
+ %_pf:ev(polarform(ex), simp),
+ /* Purely imaginary numbers somtimes return just %e^{...} */
+ if is(part(%_pf,1)=%e) then return(%_pf),
+ /* We really do have something in the form r*%e^theta to pick apart. */
+ %_pf:args(%_pf),
+ %_r:first(%_pf),
+ %_theta:part(second(%_pf),2),
+ ev(%_r, simp) * %e^(ev(%i*imagpart(%_theta), simp))
+)$
+/*
+ polarform_simp(1+%i);
+ polarform_simp(0);
+ polarform_simp(1);
+ polarform_simp(-2);
+ polarform_simp(%i);
+ polarform_simp(2*%i);
+ polarform_simp(-%i);
+ polarform_simp(-2*%i);
+ polarform_simp(sqrt(3)+%i*sqrt(3));
+ polarform_simp(1/sqrt(2)*(-1+%i));
+*/
+
+
+/* Decides if an expression is precicely of the form a*10^n, where a is an integer, or a float, and n is an integer. */
+scientific_notationp(ex) := block([tn],
+ if not(safe_op(ex)="*") then return(false),
+ if not(length(args(ex))=2) then return(false),
+ tn:first(args(ex)),
+ if safe_op(tn)="-" then tn:first(args(tn)),
+ if not(integerp(tn) or floatnump(tn)) 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
@@ -353,7 +579,7 @@ anyfloat(l) := block([ret:false],
return(ret) )$
/* Decides if any floats are in the expression. */
-anyfloatex(ex) := block([partswitch,ret,kloop],
+anyfloatex(ex) := block([partswitch, end, ret, kloop],
ret:false,
ex:ev(ex,simp),
if floatnump(ex) then return(true),
@@ -364,6 +590,78 @@ anyfloatex(ex) := block([partswitch,ret,kloop],
return(ret)
)$
+/* Apply radcan to things which look like a number. Needed to transform expressions
+ like "2^(3/2)/sqrt(3)-(2*sqrt(6))/3" to zero, without expanding out brackets in general. */
+radcan_num(ex):= block(
+ if atom(ex) then return(ex),
+ /* Something without variables should have radcan applied. */
+ if emptyp(listofvars(ex)) then return(radcan(ex)),
+ apply(op(ex), map(radcan_num, args(ex)))
+)$
+
+/* Check if - appears in an expression. */
+freeof_mminusp(ex) := block(
+ if atom(ex) then return(true),
+ if safe_op(ex)="-" then return(false),
+ all_listp(freeof_mminusp, args(ex))
+)$
+
+/* Fine control over the display of complex numbers.
+ This general purpose function "does the right thing" with simplification assumed to be true.
+*/
+display_complex(ex) := block([exr, exi],
+ if real_numberp(ex) then return(ex),
+ exr:ev(realpart(ex), simp),
+ exi:ev(imagpart(ex), simp),
+ if is(exr=0) then exr:null,
+ if is(exi=1) then exi:null,
+ if ev(is(exi=-1),simp) then exi:-1*null,
+ disp_complex(exr, exi)
+ )$
+
+texdisp_complex(ex) := block([ps, sxr, exi, simp],
+ simp:false,
+ ps:"+",
+ if is(first(args(ex))=null) then block(
+ sxr:"",
+ ps:""
+ ) else sxr:tex1(first(args(ex))),
+ exi:second(args(ex)),
+
+ if real_numberp(exi) then block(
+ if ev(is(exi < 0), simp) then ps: "",
+ return(sconcat(sxr, ps, tex1(exi), "\\,", tex1(%i)))
+ ) else if ev(is(exi=null), simp) then return(sconcat(sxr, ps, tex1(%i)))
+ else if ev(is(exi=-1*null), simp) then return(sconcat(sxr, "-", tex1(%i)))
+ else block(
+ if not(freeof_mminusp(exi)) then block(
+ ps:"-",
+ /* TODO: more subtle removal of the minus sign?! */
+ exi:ev(-1*exi, simp)
+ ),
+ sconcat(sxr, ps, tex1(%i), "\\,", tex1(exi))
+ )
+)$
+texput(disp_complex, texdisp_complex)$
+
+/* Because we have null being used differently in two places we need a remove function. */
+remove_disp_complex(ex1, ex2) := ev(ex1, null=0)+ev(ex2, null=1)*%i$
+
+/* This function is a display-level way to ensure brackets get displayed. */
+texdisp_parens(ex) := sconcat("\\left( ", tex1(first(args(ex))), " \\right)")$
+texput(disp_parens, texdisp_parens)$
+
+remove_disp_parens(ex) := ev(ex, disp_parens=lambda([ex2], ex2))$
+
+/* This function is a display-level way to select part of an expression. */
+texdisp_select(ex) := sconcat("\\color{red}{\\underline{", tex1(first(args(ex))), "}}")$
+texput(disp_select, texdisp_select)$
+
+/* A single function to remove display forms. Used by answer tests to "clean" an expression. */
+
+remove_disp(ex) := ev(ex, disp_parens=lambda([ex2], ex2), disp_select=lambda([ex2], ex2), disp_complex=remove_disp_complex)$
+
+
/* This function is designed for displaying decimal places. It is also useful for currency. */
/* displaydp(n, dp) is an inert function. The tex function converts this to display. */
/* n is the number to be displayed */
@@ -399,26 +697,42 @@ remove_displaydp(ex):= block(
return(first(args(ex)))
);
+/* Remove all forms of inert wrappers of numbers. */
+remove_numerical_inert(ex) := block(
+ if atom(ex) then return(ex),
+ if safe_op(ex) = "displaysci" then return(first(args(ex))*10^third(args(ex))),
+ if safe_op(ex) = "displaysf" then return(first(args(ex))),
+ if not(freeof(displaydp, ex)) then return(remove_displaydp(ex)),
+ return(ex)
+)$
+
/* Write the number ex in n decimal places */
decimalplacesfun(ex, n, dispdps) := block([ex2],
- ex2:ev(float(round(10^n*float(ex))/(10^n)), logbase=logbasesimp, simp),
+ 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)$
+dispdp(ex, n) := block(
+ if not(real_numberp(ex)) then error("dispdp requires a real number argument."),
+ if not(integerp(n)) then error("dispdp cannot create a non-integer number of decimal places."),
+ decimalplacesfun(ex, n, true)
+)$
/* Write numbers in significant figures */
/* Matti Pauna, Sun, 23 Oct 2011 */
sigfigsfun(x, n, dispsigfigs) := block([fpprec:128, fpprintprec:16, simp:true, ex, ex1, ex2, dps],
- if not(integerp(n)) then error("significantfigures(x,n) requires an integer as a second argument."),
+ 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), logbase=logbasesimp, simp),
+ 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)
@@ -447,11 +761,21 @@ sigfigsfun(x, n, dispsigfigs) := block([fpprec:128, fpprintprec:16, simp:true, e
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],
+/*
+ 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), logbase=logbasesimp, simp),
+ 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),
@@ -465,8 +789,10 @@ scientific_notation([a]) := block([simp:false, x, ex, ex2, ex3, exn],
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))
)$
@@ -521,6 +847,18 @@ make_displayscivalue(ex):= block([n, d, expo, ss],
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 */
@@ -530,37 +868,59 @@ make_displayscivalue(ex):= block([n, d, expo, ss],
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.
-
+ 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],
+ block([keepfloat, trigexpand, logexpand, sumsplitfact, ex, vi],
+
+ if SA=SB then return(true),
+ /* Remove +- if we can early. */
+ SA:pm_replace(SA),
+ SB:pm_replace(SB),
+
/* Reject obviously different expressions. These can be very time consuming in the tests below. */
- /* The code below is actually making the situation worse: needs reconsidering. */
if numerical_not_alg_equiv(SA, SB) then return(false),
- trigexpand:true,
+ trigexpand:false,
logexpand:super,
keepfloat:true,
+ sumsplitfact:false,
/* In some cases we just go inside the function one level. */
if (safe_op(SA)=safe_op(SB) and (safe_op(SA)="sqrt" or safe_op(SA)="abs")) then
(SA:first(args(SA)),
SB:first(args(SB))),
+ /* Remove stackeq. */
+ SA:remove_stackeq(SA),
+ SB:remove_stackeq(SB),
/* Remove scientific units and displaydp from expressions. */
SA:ev(SA, stackunits="*"),
SB:ev(SB, stackunits="*"),
- if not(freeof(displaydp, SA)) then
- SA:remove_displaydp(SA),
- if not(freeof(displaydp, SB)) then
- SA:remove_displaydp(SB),
+ /* 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),
+ SA:remove_numerical_inert(SA),
+ SB:remove_numerical_inert(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),
+ 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)),
+ 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)
@@ -570,28 +930,30 @@ algebraic_equivalence(SA, SB) :=
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)),
+ 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(lambda([ex2], algebraic_equivalence(ex2, 0)), args(ex))) then return(false),
+ if not(any_listp(algebraic_equivalence_zero, 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)),
+ 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 (print("algebraic_equivalence: evaluating the difference of two expressions threw an error."), return(false)),
+ if ex=[] then error("algebraic_equivalence: evaluating the difference of two expressions threw an error."),
ex:ex[1],
if floatnump(ex) then return(false),
ex:num(ex), /* after a fullratsimp, we have a ratio. We should only need to consider the top */
+ trigexpand:true,
ex:trigsimp(ex),
if not(freeof(%i, ex)) then ex:rectform(ex),
ex:exponentialize(ex),
/* ex:trigreduce(ex), CJS, removed 21/1/2010. This was breaking ATSingleFrac! Don't know why. */
if ratsimp(ex)=0 then return(true),
+ /* Radcan is slow, and may be causeing timeouts... */
ex:radcan(ex),
ex:factcomb(ex),
if ratsimp(ex)=0 then return(true),
@@ -599,29 +961,78 @@ algebraic_equivalence(SA, SB) :=
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],
+numerical_not_alg_equiv(p1, p2):= block([pvars, pval, lv, sz, pnum, stack_mtell_quiet,listdummyvars],
+ stack_mtell_quiet:true,
+ listdummyvars:false,
/* We take the *union* of the two lists of variables, this way we
- hedge against comparing (x+a)+(x-a) with 2*x, which are the same. */
- pvars:listofvars([p1,p2]),
+ hedge against comparing (x+a)+(x-a) with 2*x, which are the same.
+ See issue #748 to see why listofvars([p1,p2]) was changed below.
+ */
+ pvars:unique(append(listofvars(p1),listofvars(p2))),
/* Evaluate as integers to start with and avoid floats. This is safer, and works in many cases.*/
lv:zip_with("=", pvars, makelist(ev(k+1,simp), k, length(pvars))),
- pval:errcatch(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),
+ pval:errcatch(subst(lv, p1-p2)),
+ if is(pval = []) then (print("STACK: ignore previous error. (1)"), return(false)),
+ pval:errcatch(ev(first(pval), lg=logbasesimp, simp)),
+ /* We can't remove all these with stack_mtell_quiet, because some are division by zero
+ which are errors, not warnings. */
+ if is(pval = []) then (print("STACK: ignore previous error. (2)"), return(false)),
+ /* User functions without a function rule cannot be evaluated numerically */
+ if recurse_userfunctionp(first(pval)) then return(false),
+ pval:errcatch(ev(is(abs(first(pval)) > 1/10000), simp)),
+ if is(pval = []) then (print("STACK: ignore previous error. (3)"), return(false)),
+ if first(pval) then return(true),
/* Evaluate the difference of the expressions at each variable as floats. */
lv:zip_with("=", pvars, makelist(float((sqrt(2)^k+k*%pi)/4), k, length(pvars))),
+ /* Maxima 5.43.0 and onwards take a very long time to return "unknown" when we don't have a float in the first place. */
+ /* Add a guard cluase for things we can't check numerically. */
+ if recurse_predp(p1, numerical_not_expressionp) or recurse_predp(p2, numerical_not_expressionp) then return(false),
/* Now we evaluate the difference of the expressions at each variable. */
- p1:errcatch(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)$
+ p1:errcatch(subst(lv, p1)),
+ if is(p1 = []) then (print("STACK: ignore previous error. (4)"), return(false)),
+ p1:errcatch(ev(float(first(p1)), lg=logbasesimp, numer_pbranch:true, simp)),
+ if is(p1 = []) then (print("STACK: ignore previous error. (5)"), return(false)),
+ p2:errcatch(subst(lv, p2)),
+ if is(p2 = []) then (print("STACK: ignore previous error. (6)"), return(false)),
+ p2:errcatch(ev(float(first(p2)), lg=logbasesimp, numer_pbranch:true, simp)),
+ if is(p2 = []) then (print("STACK: ignore previous error. (7)"), return(false)),
+ /* Make the error here relative, and don't divide by zero. */
+ sz:errcatch(ev(abs(float(first(p1)-first(p2))/max(min(abs(first(p1)),abs(first(p2))),1)), simp)),
+ if is(sz = []) then (print("STACK: ignore previous error. (8)"), return(false)),
+ pnum:errcatch(floatnump(first(sz))),
+ if is(pnum = []) then (print("STACK: ignore previous error. (9)"), return(false)),
+ if not(first(pnum)) then return(false),
+ if first(sz) > 0.0001 then true else false
+)$
+
+/* Are there any user-defined function? */
+recurse_userfunctionp(ex):= block([op1],
+ if atom(ex) then return(false),
+ op1:ev(op(ex)),
+ /* Functions like li use arrays, e.g. li[2](-x). */
+ /* While this code does not distinguish between the following, we want to reject
+ all arrays
+ p0:li[2](-2*%e^(2*t));
+ p1:b[1];
+ p2:b[1][2];
+ p3:b[1](x);
+ p4:b[1][2](x);
+ */
+ if arrayp(op1) then while arrayp(op1) do op1:ev(op(op1)),
+ op1:apply(properties,[op1]),
+ if emptyp(op1) then return(true),
+ apply("or", map(recurse_userfunctionp, args(ex)))
+)$
+
+/* We can try to evaluate matrices here, but anything else is out. */
+numerical_not_expressionp(ex) := block(
+ /* Noun calculus operations get evaluated, which throws an erros. */
+ if listp(ex) or equationp(ex) or inequalityp(ex) or safe_setp(ex) or functionp(ex) or logicp(ex) or stringp(ex) or calculusp(ex) then
+ return(true),
+ return(false)
+);
/* This function takes two expressions.
It establishes if there exists a substitution of the variables of ex2 into ex1 which renders
@@ -634,40 +1045,52 @@ numerical_not_alg_equiv(p1, p2):= block([pvars, pval, lv, sz],
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],
+subst_equiv([ex]):=block([ex1, ex2, l1, lv1, lv2, lvi, lvp, lvs, lve, lvpres, il, perm_size, simp],
+ /* Maintain back-compatibility. */
+ ex1: first(ex),
+ ex2: second(ex),
+ l1:[],
+ if length(ex)>2 then l1:third(ex),
+ if not(listp(l1)) then error("The third argument to subst_equiv must be a list of variables."),
simp:true,
perm_size:4, /* This algorithm is order factorial(perm_size) and so this needs to be small. */
lv1:setify(listofvars(ex1)),
lv2:setify(listofvars(ex2)),
/* If any of the variables also appear as function names we should get rid of them.
Otherwise we get an infinite loop. */
- lv1:listify(setdifference(lv1, get_ops(ex1))),
- lv2:listify(setdifference(lv2, get_ops(ex2))),
+ lv1:setdifference(lv1, get_ops(ex1)),
+ lv2:setdifference(lv2, get_ops(ex2)),
if length(lv1)#length(lv2) then return([]),
+ /* We don't include any variables which the teacher fixes. */
+ if not(emptyp(l1)) then (
+ l1:setify(l1),
+ lv1:setdifference(lv1, l1),
+ lv2:setdifference(lv2, l1)
+ ),
/* If the lists are too long, try a weaker condition */
/* We assume the variables which occur in both are correctly assigned. */
/* Can we find a permutation of those left in each? */
if length(lv1)>perm_size then (
- lv1:setify(lv1),
- lv2:setify(lv2),
lvi:intersection(lv1, lv2),
- lv1:listify(setdifference(lv1, lvi)),
- lv2:listify(setdifference(lv2, lvi))
+ lv1:setdifference(lv1, lvi),
+ lv2:setdifference(lv2, lvi)
),
+ lv1:listify(lv1),
+ lv2:listify(lv2),
if length(lv1)>perm_size then return(false),
/* */
- lvp:listify(permutations(lv2)),
+ lvp:listify(permutations(lv1)),
/* Create a list of subsitutions */
- lvs:map(lambda([ex], zip_with("=", lv1, ex)), lvp),
- /* Create list of expressions with which to compare ex1 */
+ lvs:map(lambda([ex], zip_with("=", ex, lv2)), lvp),
+ lvs:map(sort, lvs),
+ /* Create list of expressions with which to compare ex1 */
lve:map(lambda([ex], ev(ex1, ex)), lvs),
lve:map(lambda([ex], ATAlgEquivfun(ex, ex2)), lve),
lve:map(second,lve),
- lve:map(lambda([ex], equal(ex, true)),lve),
+ lve:map(lambda([ex], equal(ex, true)), lve),
if apply("or", lve) then (il:sublist_indices(lve, identity), lvs[il[1]]) else []
)$
-
/* ********************************** */
/* Simplification control */
/* ********************************** */
@@ -683,179 +1106,28 @@ STACK_assoc(ex, oplist) := block(
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.
-*/
+/****************************************************************/
+/* Define noun versions of logical "and" and "or". */
+/****************************************************************/
-/* (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)))
+noun_logic_remove(ex) := block([rex],
+ rex:opsubst("and", "nounand", ex),
+ rex:opsubst("or", "nounor", rex),
+ rex:opsubst("not", "nounnot", rex),
+ return(rex)
)$
-/* 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])
+noun_logic(ex) := block([rex],
+ rex:subst("nounand", "and", ex),
+ rex:subst("nounor", "or", rex),
+ rex:subst("nounnot", "not", rex),
+ rex
)$
-/* Legacy support for direct access to this function. */
-alias(ATEqual_com_ass, ATEqualComAss)$
-
-/****************************************************************/
-/* Define noun versions of logical "and" and "or". */
-/****************************************************************/
-
nary("nounand", 65)$
nary("nounor", 61)$
+prefix("nounnot", 70)$
declare("nounand", commutative)$
declare("nounand", lassociative)$
@@ -878,16 +1150,22 @@ logicp(ex) := block(
if logic_edgep(ex) then return(true),
if safe_op(ex) = "nounand" then return(true),
if safe_op(ex) = "nounor" then return(true),
+ if safe_op(ex) = "nounnot" then return(true),
if safe_op(ex) = "and" then return(true),
if safe_op(ex) = "or" then return(true),
if safe_op(ex) = "not" then return(true),
- if op_usedp(ex, "+-") then return(true),
+ if safe_op(ex) = "nor" then return(true),
+ if safe_op(ex) = "nand" then return(true),
+ if safe_op(ex) = "xor" then return(true),
+ if safe_op(ex) = "xnor" then return(true),
+ if safe_op(ex) = "implies" then return(true),
+ if op_usedp(ex, STACKpmOPT) then return(true),
return(false)
)$
free_of_logicp(ex) := block([logicops, logiconsts, res, k],
if is(ex=all) or is(ex=none) then return(false),
- logicops:["nounand", "nounor", "and", "or", "%and", "%or", "not", "%not", "+-", "<", ">", "<=", ">=", "=", "[", "{"],
+ logicops:["nounand", "nounor", "nounnot", "and", "or", "%and", "%or", "not", "%not", STACKpmOPT, "<", ">", "<=", ">=", "=", "[", "{"],
res:true,
for k: 1 thru length(logicops) do
if ev(not(is(count_op(ex, logicops[k])=0)),simp) then res:false,
@@ -926,13 +1204,17 @@ distrib_and(ex):=block([orlisti, orlist1, orlist2],
logical_normal(ex):=block(
/* Change the noun logical operators into associative indenpotent ones. */
ex:abs_replace_eq(ex),
+ ex:boolean_form(ex),
ex:subst("%and", "nounand", ex),
ex:subst("%or", "nounor", ex),
/* %not is not an infix operator... */
ex:subst(%not, "not", ex),
+ ex:subst(%not, "nounnot", ex),
ex:subst("%and", "and", ex),
ex:subst("%or", "or", ex),
ex:de_morgan(ex),
+ ex:trigsimp(ex),
+ ex:exponentialize(ex),
ex:ineqprepare(expand(ex)),
ex:noun_solve_logic(ex),
ex:distrib_and(ex),
@@ -977,6 +1259,7 @@ logic_to_poly(ex) := block(
if polynomialp(ex, listofvars(ex)) then return(ex),
/* Solve an equation by factoring and joining each factor with =0 */
+ if equationp(ex) then ex:subst("%or", "nounor", pm_replace(ex)),
if equationp(ex) then return(ineqprepare(ex)),
if not(logicp(ex) or safe_op(ex) = "%and" or safe_op(ex) = "%or") then return(ex),
@@ -986,6 +1269,7 @@ logic_to_poly(ex) := block(
if (all_listp(equationp, ex2)) then
ex:apply("*", maplist(lhs, ex2))=0
),
+
return(ex)
)$
@@ -995,36 +1279,38 @@ logic_to_poly_helper(ex, v) := block(
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)$
+/* Maxima does not require more than one argument to diff, e.g. diff(sin(x)) is ok in maxima.
+ But, for student input we should require the variable! */
+nounint([ex]):= if ev(is(length(ex)>1),simp) then apply(nounify(int), ex) else error("int must have at least two arguments.")$
+noundiff([ex]):= if ev(is(length(ex)>1),simp) then apply(nounify(diff), ex) else error("diff must have at least two arguments.")$
+nounlimit([ex]):=apply(nounify(limit), ex)$
/* ********************************** */
/* Add in a +- operator */
/* ********************************** */
/* We have to define +- to be both a prefix and an nary operator in this order. */
-prefix("+-");
-nary("+-", 100);
+/* 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, a1, a2],
+displaypmtex(ex):=block([al],
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, "}")
+ al:maplist(tex1, al),
+ sconcat("{", simplode(al, " \\pm "), "}")
);
-texput("+-", displaypmtex);
+texput(STACKpmOPT, displaypmtex);
+
+matchdeclare(pmpatex1,true);
+matchdeclare(pmpatex2,true);
+tellsimpafter(-(pmpatex1 #pm# pmpatex2),(-pmpatex1) #pm# pmpatex2);
/* Count the occurance of an operator. */
count_op(ex, ops):= block([count],
@@ -1040,7 +1326,7 @@ count_op(ex, ops):= block([count],
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)),
+ if ev(is(count_op(ex, STACKpmOPT)=1), simp) then return(opsubst("+", STACKpmOPT, ex) nounor opsubst("-", STACKpmOPT, ex)),
return(ex)
)$
@@ -1098,13 +1384,17 @@ abs_replace_eq(ex):=block([exn, assume_pos],
/* 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(p) is true if p equals its factored form. */
factorp(argfac) := block([a],
+ if safe_op(argfac)="-" then
+ argfac:part(argfac,1),
if ev(argfac=factor(argfac), simp) then
return(true),
+ if integerp(argfac) then
+ return(false),
if mapatom(argfac) then
- return(false),
- /* Note, in Maxima factor((1-x)) = -(x-1), so we need to fix this, for learning and teaching! */
+ 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))
@@ -1116,19 +1406,19 @@ factorp(argfac) := block([a],
return(false)
)$
-/* Write the polynomial in completed square form */
+/* 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. "),
+ error("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. "),
+ error("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. "),
+ 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),
@@ -1141,6 +1431,9 @@ 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. */
@@ -1148,12 +1441,71 @@ factor_bag(ex) := block(
/* Remove any numbers. */
ex:sublist(ex, lambda([ex2], ev(not(is(listofvars(ex2)=[])), simp))),
return(ex)
-);
+)$
+
+/* Terms of the form [a]*v_1, where we have exactly one substantive term which satisfies the predicate p, multiplied by numbers.
+ Numbers on their own don't count here.
+*/
+linear_term_p(ex, p) := block([ex1],
+ if p(ex) then return(true),
+ if not(safe_op(ex)="*") then return(false),
+ ex1:args(ex),
+ if not(length(sublist(ex1, p))=1) then return(false),
+ ex1:sublist(ex1, lambda([ex2], not(p(ex2)))),
+ return(all_listp(real_numberp, ex1))
+)$
+
+/* Establishes if an expression is a linear combination of terms
+ for which the predicate p is true.
+*/
+linear_combination_p(ex, p) := block(
+ if linear_term_p(ex, p) then return(true),
+ if not(safe_op(ex)="+") then return(false),
+ ex:args(ex),
+ ex:map(lambda([ex1], linear_term_p(ex1, p)), ex),
+ return(apply("and", ex))
+)$
+
+/*
+ Write the polynomial ex, in variable v, about the point v=a.
+ Ex. x^2=1-2*(x-1)+(x-1)^2 when written about x=1.
+ This is basically the Taylor series for the polynomial about x=1, but
+ it can readily be calculated by "shift-expand-shift" and without derivatives.
+ See doi:10.1017/S0025557200003569
+*/
+poly_about_a(ex, v, a) := block(
+ if not(polynomialp(ex, [v])) then return(ex),
+ ex:ev(expand(ev(ex, ev(v)=''v+a)), simp),
+ return((ev(ex, ev(v)=''v-a)))
+)$
/****************************/
/* Matrix/vector operations */
/****************************/
+
+/* Create an "ephemeral form" for vectors, much like stackunits. */
+texboldatoms(ex) := block(
+ if numberp(ex) then return(ex),
+ if atom(ex) then return(stackvector(ex)),
+ if arrayp(ex) then return(arraymake(op(ex), maplist(texboldatoms, args(ex)))),
+ apply(op(ex), maplist(texboldatoms, args(ex)))
+)$
+
+stackvectortex(ex):= block(
+ sconcat("{\\bf ", tex1(first(args(ex))), "}")
+);
+texput(stackvector, stackvectortex);
+
+/* Remove stackvectors. Needed for dispvalue. */
+destackvector(ex):= block([argsex],
+ if mapatom(ex) then return(ex),
+ argsex:args(ex),
+ if op(ex) = stackvector then return(destackvector(argsex[1])),
+ if op(ex) = "/" then return(destackvector(argsex[1])/destackvector(argsex[2])),
+ map(destackvector, ex)
+)$
+
/*
Description : forme echelonne par lignes d'une matrice rectangulaire
(a coefficients dans un corps commutatif).
@@ -1178,11 +1530,11 @@ rowswap(m,i,j) := block([n, p, 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"),
+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"),
@@ -1192,9 +1544,9 @@ addrow(m,i,j,k) := block([n,p],
)$
rowmul(m,i,k) := block([n,p],
- require_matrix(m, "first", "addrow"),
- require_integer(i, "second", "addrow"),
- require_rational(k, "fourth", "addrow"),
+ 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),
@@ -1231,7 +1583,7 @@ rref(m):= block([p,nr,nc,i,j,k,pivot,pivot_row,debug],
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]))),
+ if not (k=ci) then (p : rowadd(p,k,ci,-p[k,cj]))),
ci : ci+1, cj : cj+1)),
p
)$
@@ -1304,10 +1656,12 @@ mediant(ex1,ex2) := (num(ex1)+num(ex2))/(denom(ex1)+denom(ex2));
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!}}");
@@ -1319,6 +1673,23 @@ 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);
@@ -1327,12 +1698,21 @@ texput(all, "\\mathbb{R}");
declare(none, constant);
texput(none, "\\emptyset");
-/* stackeq is an intert prefix equality symbol. */
-stackeqtex(ex):=block([ss, n, dp],
+/* 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. */
@@ -1344,13 +1724,12 @@ texput(stackeq, stackeqtex);
/* 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 not(listp(ex)) then error("stack_eval_arg expects to receive a list."),
if emptyp(ex) then return(matrix([true, EMPTYCHAR, [], EMPTYCHAR, ""])),
if length(ex)=1 then return(matrix([true, EMPTYCHAR, first(ex), EMPTYCHAR, ""])),
/* Set up empty rows to hold the answer. */
eqoutcome:makelist(false, length(ex)),
eqoutsymb:makelist(QMCHAR, length(ex)),
- exnatdomain:makelist(EMPTYCHAR, length(ex)),
eqoutnote:makelist("", length(ex)),
eqoutcome[1]:null,
eqoutsymb[1]:EMPTYCHAR,
@@ -1362,12 +1741,13 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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),
+ 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. */
@@ -1375,13 +1755,9 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
if is(SA=true) then SA:all,
SA:abs_replace_eq(SA),
- SA:ev(SA, logbase=logbasesimp),
+ SA:ev(SA, lg=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),
+ 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 */
@@ -1400,6 +1776,7 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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)],
@@ -1407,16 +1784,34 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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),
+
+ /* 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. */
@@ -1425,7 +1820,7 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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],
+ ([FAA, FAB, PECret],
malrulecont:false,
eqoutcome[ev(id, simp)]:true,
eqoutsymb[ev(id, simp)]:EQUIVCHAR,
@@ -1435,9 +1830,9 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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],
+ 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),
+ 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),
@@ -1446,20 +1841,17 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
facbA:apply("*", facbA),
facbB:apply("*", facbB),
ATres:ev(ATAlgEquiv(facbA, facbB), simp),
- if (debug) then print(ATres),
+ 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 cause of real single variable equations. */
+ ) 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),
@@ -1532,6 +1924,18 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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
(
@@ -1557,14 +1961,116 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
)
),
- /* 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,
+ /* 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. */
@@ -1676,13 +2182,35 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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))
+ 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)]),
@@ -1712,18 +2240,55 @@ stack_eval_arg(ex) := block([eqoutcome, eqoutsymb, eqoutnote, res, id, truthargu
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)
+ 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, equivdebug, debuglist) := block([A, k, ret, res, exnew, eqoutsymb, note],
+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. */
@@ -1731,7 +2296,8 @@ stack_eval_equiv_arg(ex, showlogic, equivdebug, debuglist) := block([A, k, ret,
/* 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
+ /* 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. */
@@ -1751,7 +2317,7 @@ stack_eval_equiv_arg(ex, showlogic, equivdebug, debuglist) := block([A, k, ret,
)
)
) else (
- print("ERROR, disp_stack_eval_arg: length of debuglist is ", string(length(debuglist)), ", but the length of the argument is ", string(length(eqoutsymb)), ".")
+ 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. */
@@ -1770,7 +2336,8 @@ stack_eval_equiv_arg(ex, showlogic, equivdebug, debuglist) := block([A, k, 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),
+ /* If we return a list, then the PHP unpacking side now has problems, but we want to encapsulate the note as a single object, without | characters */
+ note:sconcat("(", simplode(second(A), ","), ")"),
return([res, ret, note])
)$
@@ -1793,26 +2360,49 @@ stack_eval_arg_equivalence_reasoningp(L) := block(
)$
/* 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),
+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(ex, showlogic) := block([A],
- A:stack_eval_equiv_arg(ex, showlogic, false, false),
+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),
+ 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],
+ATEquiv([ex]) := block([SA, SB, SO, SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+ SA:first(ex),
+ SB:second(ex),
+ SO:[],
+ if length(ex)>2 then SO:third(ex),
/* Turn on simplification and error catch. */
SAA:errcatch(ev(SA, simp, nouns)),
@@ -1828,6 +2418,7 @@ ATEquiv(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack]
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
@@ -1836,7 +2427,7 @@ ATEquiv(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack]
(print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATEquiv_SB_not_list"))),
/* Actually perform the test. */
- A:stack_eval_equiv_arg(SA, true, false, false),
+ A:stack_eval_equiv_arg(SA, true, true, false, false),
AnswerNote:third(A),
FeedBack:stack_disp(second(A), "d"),
@@ -1845,7 +2436,11 @@ ATEquiv(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack]
)$
/* An answer test based on equivalence reasoning. */
-ATEquivFirst(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos],
+ATEquivFirst([ex]) := block([SA, SB, SO, SAA, SAB, SOO, opts, ret, A, AnswerNote, FeedBack, assume_pos:false],
+ SA:first(ex),
+ SB:second(ex),
+ SO:[],
+ if length(ex)>2 then SO:third(ex),
/* Turn on simplification and error catch. */
SAA:errcatch(ev(SA, simp, nouns)),
@@ -1861,6 +2456,7 @@ ATEquivFirst(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, Feed
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
@@ -1877,7 +2473,7 @@ ATEquivFirst(SA, SB, SO) := block([SAA, SAB, SOO, opts, ret, A, AnswerNote, Feed
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),
+ A:stack_eval_equiv_arg(SA, true, true, false, false),
AnswerNote:third(A),
FeedBack:stack_disp(second(A), "d"),
diff --git a/stack/2017121800/maxima/assessment.texi b/stack/2023102700/maxima/assessment.texi
similarity index 98%
rename from stack/2017121800/maxima/assessment.texi
rename to stack/2023102700/maxima/assessment.texi
index 8e3b16f1e6bb5a1160d1e9f4ea95ec1623fe0521..2f5fc371f86022a353bd2a1a51a64cfe4f469cfd 100644
--- a/stack/2017121800/maxima/assessment.texi
+++ b/stack/2023102700/maxima/assessment.texi
@@ -309,26 +309,26 @@ This test seeks to establish whether two expressions are the same when the basic
The first step is to replace all arithmetic operations by a pseudo-noun form as follows.
-@deffn {Function} noun+ (@var{[ex]})
+@deffn {Function} nounadd (@var{[ex]})
This is a commutative, associative, nary operator. Normal addition is replaced by this operator when we are testing for equivalence up to associativity and commutativity.
@end deffn
-@deffn {Function} noun* (@var{[ex]})
+@deffn {Function} nounmul (@var{[ex]})
This is a commutative, associative, nary operator. Normal multiplication is replaced by this operator when we are testing for equivalence up to associativity and commutativity.
@end deffn
-@deffn {Function} noun^ (@var{a},@var{b})
+@deffn {Function} nounpow (@var{a},@var{b})
This is a binary infix operator. Normal exponentiation is replaced by this operator when we are testing for equivalence up to associativity and commutativity.
@end deffn
-@deffn {Function} 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.
+@deffn {Function} nounsub (@var{ex})
+This is a prefix operator. This is to match unary minus when we are testing for equivalence up to associativity and commutativity. However, in practice unary minus, @code{"-"(ex)}, is replaced by @code{UNARY_MINUS nounmul ex} so that it correctly commutes with multiplication.
@end deffn
We need functions which will transform expressions between these forms.
@deffn {Function} noun_arith (@var{ex})
-All operations are replaced with their noun forms. Note that unary minus function, @code{"-"(ex)} is replaced by @code{UNARY_MINUS noun* ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 noun* (UNARY_RECIP ex2)}.
+All operations are replaced with their noun forms. Note that unary minus function, @code{"-"(ex)} is replaced by @code{UNARY_MINUS nounmul ex} so that it correctly commutes with multiplication. Similarly, @code{ex1/ex2} is replaced by @code{ex1 nounmul (UNARY_RECIP ex2)}.
@end deffn
@deffn {Function} verb_arith (@var{ex})
diff --git a/stack/2023102700/maxima/contrib/validators.mac b/stack/2023102700/maxima/contrib/validators.mac
new file mode 100644
index 0000000000000000000000000000000000000000..80e9e8d0cc15d779bada1c477f0f41e3d3cf0077
--- /dev/null
+++ b/stack/2023102700/maxima/contrib/validators.mac
@@ -0,0 +1,33 @@
+/* Author Chris Sangwin
+ University of Edinburgh
+ Copyright (C) 2023 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/****************************************************************/
+/* Bespoke validators for STACK inputs */
+/* */
+/* Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* V1.0 June 2023 */
+/* */
+/* Please use this file to add public bespoke validators. */
+/* */
+/****************************************************************/
+
+/* The student may not use an underscore anywhere in their input. */
+
+validate_underscore(ex) := if is(sposition("_", string(ex)) = false) then ""
+ else "Underscore characters are not permitted in this input.";
+
+/* Add in unit-test cases using STACK's s_test_case function. At least two please! */
+s_test_case(validate_underscore(1+a1), "");
+s_test_case(validate_underscore(1+a_1), "Underscore characters are not permitted in this input.");
diff --git a/stack/2023102700/maxima/contrib/vectorcalculus.mac b/stack/2023102700/maxima/contrib/vectorcalculus.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e41351c22bcbabb143c2cd40e3b780aaa036a5a8
--- /dev/null
+++ b/stack/2023102700/maxima/contrib/vectorcalculus.mac
@@ -0,0 +1,48 @@
+/* Author Luke Longworth
+ University of Canterbury
+ Copyright (C) 2023 Luke Longworth
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/****************************************************************/
+/* Vector calculus functions for STACK */
+/* */
+/* V1.0 June 2023 */
+/* */
+/****************************************************************/
+
+/****************************************************************/
+/* Calculate the divergence of a vector-valued function */
+/****************************************************************/
+div(u, vars):= block([div_vec],
+ if not(listp(vars)) or emptyp(vars) then error("div: the second argument must be a list of variables."),
+ if matrixp(u) then funcs: list_matrix_entries(u) else funcs: flatten(u),
+ /* TODO: confirm div should always simplify? */
+ div_vec: map(lambda([ex], ev(diff(funcs[ex],vars[ex]), simp)), ev(makelist(ii,ii,1,length(vars)), simp)),
+ return(apply("+", div_vec))
+);
+
+s_test_case(div([x^2*cos(y),y^3],[x,y]), 2*x*cos(y)+3*y^2);
+s_test_case(div(transpose(matrix([x^2*cos(y),y^3])),[x,y]), 2*x*cos(y)+3*y^2);
+s_test_case(div(matrix([x^2*cos(y),y^3]),[x,y]), 2*x*cos(y)+3*y^2);
+
+/****************************************************************/
+/* Calculate the curl of a vector-valued function */
+/****************************************************************/
+curl(u,vars):= block([cux, cuy, cuz],
+ if not(listp(vars)) or emptyp(vars) then error("curl: the second argument must be a list of 3 variables."),
+ if matrixp(u) then [ux,uy,uz]: list_matrix_entries(u) else [ux,uy,uz]: flatten(u),
+ cux: diff(uz,vars[2]) - diff(uy,vars[3]),
+ cuy: diff(ux,vars[3]) - diff(uz,vars[1]),
+ cuz: diff(uy,vars[1]) - diff(ux,vars[2]),
+ return(transpose(matrix([cux,cuy,cuz])))
+);
diff --git a/stack/2023102700/maxima/elementary.mac b/stack/2023102700/maxima/elementary.mac
new file mode 100644
index 0000000000000000000000000000000000000000..f495a9a5f69424ecfb452c88e69f9b9f954cd73e
--- /dev/null
+++ b/stack/2023102700/maxima/elementary.mac
@@ -0,0 +1,195 @@
+/* Author Chris Sangwin
+ University of Birmingham
+ Copyright (C) 2013 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+
+/* THIS IS EXPERIMENTAL CODE */
+/* Most of the code is now in noun_simp.mac. This is the remainder. */
+
+
+/*******************************************/
+/* Control functions */
+/*******************************************/
+
+DIS_TRANS:["disAddMul"]$
+POW_TRANS:["powLaw"]$
+BUG_RULES:["buggyPow","buggyNegDistAdd"]$
+
+/* Is the rule applicable at the top level? */
+trans_topp(ex,rl):=apply(parse_string(sconcat(rl,"p")),[ex])$
+
+/* Is the rule applicable anywhere in the expression? */
+trans_anyp(ex, rl):=block(
+ if atom(ex) then return(trans_topp(ex,rl)),
+ if trans_topp(ex,rl) then return(true),
+ apply("or",maplist(lambda([ex2],trans_anyp(ex2,rl)),args(ex)))
+)$
+
+/* Identify applicable rules at the top level */
+trans_top(ex):=sublist(ALL_TRANS, lambda([ex2],trans_topp(ex,ex2)))$
+
+/* Identify applicable rules */
+trans_any(ex):=sublist(ALL_TRANS, lambda([ex2],trans_anyp(ex,ex2)))$
+
+/*******************************************/
+/* Higher level control functions */
+/*******************************************/
+
+/* Very inefficient! */
+/* Has the advantage that the whole expression is always visible at the top level */
+step_through(ex):=block([rls],
+ rls:trans_any(ex),
+ if emptyp(rls) then return(ex),
+ print(string(ex)),
+ print(rls),
+ step_through(transr(ex,first(rls)))
+)$
+
+/* This only looks at the top level for rules which apply. If none, we look deeper. */
+/* This is much more efficient */
+step_through2(ex):=block([rls,rl,ex2],
+ if atom(ex) then return(ex),
+ rls:trans_top(ex),
+ if emptyp(rls) then return(block([ex2], ex2:map(step_through2,ex), if ex=ex2 then ex else step_through2(ex2))),
+ rl:first(rls),
+ ex2:apply(parse_string(rl),[ex]),
+ print([ex,rl,ex2]),
+ if ex=ex2 then ex else step_through2(ex2)
+)$
+
+/* Assume some rules are just applied in the background */
+step_through3(ex):=block([rls],
+ rls:sublist(ALG_TRANS, lambda([ex2],trans_anyp(ex,ex2))),
+ if not(emptyp(rls)) then return(step_through3(transr(ex,first(rls)))),
+ rls:trans_any(ex),
+ if emptyp(rls) then return(ex),
+ print(string(ex)),
+ print(rls),
+ step_through3(transr(ex,first(rls)))
+)$
+
+/* removes elements of l1 from l2. */
+removeoncelist(l1,l2):=block(
+ if listp(l2)#true or emptyp(l2) then return([]),
+ if listp(l1)#true or emptyp(l1) then return(l2),
+ if element_listp(first(l1),l2) then return(removeoncelist(rest(l1),removeonce(first(l1),l2))),
+ removeoncelist(rest(l1),l2)
+)$
+
+/* A special function.
+ If a\in l1 is also in l2 then remove a and -a from l2.
+ Used on negDef */
+removeoncelist_negDef(l1,l2):=block(
+ if listp(l2)#true or emptyp(l2) then return([]),
+ if listp(l1)#true or emptyp(l1) then return(l2),
+ if element_listp(first(l1),l2) then return(removeoncelist_negDef(rest(l1),removeonce("-"(first(l1)),removeonce(first(l1),l2)))),
+ removeoncelist_negDef(rest(l1),l2)
+)$
+
+/*******************************************/
+/* Transformation rules (not used) */
+/*******************************************/
+
+/* -1*x -> -x */
+negMinusOnep(ex):=block(
+ if safe_op(ex)#"*" then return(false),
+ if is(first(args(ex))=negInt(-1)) then return(true) else return(false)
+)$
+
+negMinusOne(ex):=block(
+ if negMinusOnep(ex)#true then return(ex),
+ if length(args(ex))>2 then "-"(apply("*",rest(args(ex)))) else -second(args(ex))
+)$
+
+/* a-a -> 0 */
+/* This is a complex function. If "a" and "-a" occur as arguments in the sum
+ then we remove the first occurance of each. Then we add the remaining arguments.
+ Hence, this does not flatten arguments or re-order them, but does cope with nary-addition
+*/
+negDefp(ex):=block([a0,a1,a2,a3],
+ if safe_op(ex)#"+" then return(false),
+ a1:maplist(first,sublist(args(ex), lambda([ex2],safe_op(ex2)="-"))),
+ a2:sublist(args(ex), lambda([ex2],safe_op(ex2)#"-")),
+ any_listp(lambda([ex2],element_listp(ex2,a2)),a1)
+)$
+
+negDef(ex):=block([a0,a1,a2,a3],
+ if negDefp(ex)#true then return(ex),
+ a0:args(ex),
+ a1:maplist(first,sublist(args(ex), lambda([ex2],safe_op(ex2)="-"))),
+ a2:sublist(args(ex), lambda([ex2],safe_op(ex2)#"-")),
+ a3:removeoncelist_negDef(a1,a0),
+ if emptyp(a3) then 0 else apply("+",a3)
+)$
+
+/* Distributes "-" over addition */
+negDistAddp(ex):=block(
+ if safe_op(ex)#"-" then return(false),
+ if safe_op(part((ex),1))="+" then true else false
+)$
+
+negDistAdd(ex):=block(
+ if negDistAddp(ex) then map("-",part((ex),1)) else ex
+)$
+
+
+
+/*******************************************/
+/* Division rules */
+
+/* a/a -> 1 */
+idDivp(ex):= if safe_op(ex)="/" and part(ex,1)=part(ex,2) and part(ex,2)#0 then true else false$
+idDiv(ex) := if idDivp(ex) then 1 else ex$
+
+/*******************************************/
+/* Distribution rules */
+
+/* Write (a+b)*c as a*c+b*c */
+disAddMulp(ex):= if safe_op(ex)="*" then
+ if safe_op(last(ex))="+" then true else false$
+
+disAddMul(ex):= block([S,P],
+ S:last(ex),
+ P:reverse(rest(reverse(args(ex)))),
+ P:if length(P)=1 then first(P) else apply("*", P),
+ S:map(lambda([ex], P*ex), S)
+)$
+
+/*******************************************/
+/* Power rules */
+
+/* Write a*a^n as a^(n+m) */
+powLawp(ex):= block([B],
+ if not(safe_op(ex)="*") then return(false),
+ B:sort(maplist(lambda([ex], if safe_op(ex)="^" then first(args(ex)) else ex), args(ex))),
+ if emptyp(powLawpduplicates(B)) then return(false) else return(true)
+)$
+
+powLawpduplicates(l):=block(
+ if length(l)<2 then return([]),
+ if first(l)=second(l) then return([first(l)]),
+ return(powLawpduplicates(rest(l)))
+)$
+
+powLaw(ex):= block([B,l1,l2],
+ B:sort(maplist(lambda([ex], if safe_op(ex)="^" then first(args(ex)) else ex), args(ex))),
+ B:first(powLawpduplicates(B)),
+ l1:sublist(args(ex), lambda([ex], is(ex=B) or (is(safe_op(ex)="^") and is(first(args(ex))=B)))),
+ l1:maplist(lambda([ex], if is(ex=B) then 1 else second(args(ex))), l1),
+ l2:sublist(args(ex), lambda([ex], not(is(ex=B) or (is(safe_op(ex)="^") and is(first(args(ex))=B))))),
+ if l2=[] then return(B^apply("+",l1)),
+ if length(l2)=1 then l2:first(l2) else l2:apply("*",l2),
+ return(B^apply("+",l1)*l2)
+);
+
diff --git a/stack/2023102700/maxima/errortostring.lisp b/stack/2023102700/maxima/errortostring.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..df6ba14adccbcc5a28edb087600b1cbbba22edbb
--- /dev/null
+++ b/stack/2023102700/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/2017121800/maxima/expandfeedback.mac b/stack/2023102700/maxima/expandfeedback.mac
similarity index 92%
rename from stack/2017121800/maxima/expandfeedback.mac
rename to stack/2023102700/maxima/expandfeedback.mac
index 8d688ae5ed3877bd701e4a4d10b3d9585fbd9985..a9aaf28ae39e539c26e45c80a064f456ca6ce514 100644
--- a/stack/2017121800/maxima/expandfeedback.mac
+++ b/stack/2023102700/maxima/expandfeedback.mac
@@ -23,17 +23,6 @@ COLOR_LIST:["red", "Blue" , "YellowOrange", "Bittersweet" , "BlueViolet" , "Aq
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)$
@@ -131,9 +120,3 @@ tut_expand_full(ex) := block([ret,seps],
display_steps(ret)
)$
-
-
-
-
-
-
diff --git a/stack/2023102700/maxima/experimental.mac b/stack/2023102700/maxima/experimental.mac
new file mode 100644
index 0000000000000000000000000000000000000000..ca9d949354d939c4424237af83595891f8037ef5
--- /dev/null
+++ b/stack/2023102700/maxima/experimental.mac
@@ -0,0 +1,71 @@
+/* Author Chris Sangwin
+ Lougborough University
+ Copyright (C) 2015 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <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))));
+
+/****************************************************************/
+/* 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/2023102700/maxima/fboundp.mac b/stack/2023102700/maxima/fboundp.mac
new file mode 100644
index 0000000000000000000000000000000000000000..310a43d7372614a70a58ec83865ee2c05fcea747
--- /dev/null
+++ b/stack/2023102700/maxima/fboundp.mac
@@ -0,0 +1,99 @@
+/* fboundp.mac -- detect different kinds of functions in Maxima
+ * copyright 2020 by Robert Dodier
+ * I release this work under terms of the GNU General Public License
+ *
+ * See https://github.com/maxima-project-on-github/maxima-packages/blob/master/robert-dodier/fboundp/fboundp.mac
+ *
+ * Examples:
+ *
+ /* Name of an operator: */
+ fboundp("+");
+ true;
+ fboundp_operator("+");
+ true;
+
+ infix("//") $
+ fboundp("//");
+ false;
+ fboundp_operator("//");
+ false;
+ x // y := y - x $
+ fboundp("//");
+ true;
+ fboundp_operator("//");
+ true;
+
+ /* Simplifying function defined in Lisp: */
+ fboundp(sin);
+ true;
+ fboundp_simplifying(sin);
+ true;
+
+ /* DEFUN (ordinary argument-evaluating) function defined in Lisp: */
+ fboundp(expand);
+ true;
+ fboundp_ordinary_lisp(expand);
+ true;
+
+ /* DEFMSPEC (argument-quoting) function defined in Lisp: */
+ fboundp(kill);
+ true;
+ fboundp_quoting(kill);
+ true;
+
+ /* Maxima ordinary function: */
+ (kill(foo),
+ foo(x) := x,
+ fboundp(foo));
+ true;
+ fboundp_ordinary_maxima(foo);
+ true;
+
+ /* Maxima array function: */
+ (kill(bar),
+ bar[x](y) := x*y,
+ fboundp(bar));
+ true;
+ fboundp_array_function(bar);
+ true;
+
+ /* Maxima macro: */
+ (kill(baz),
+ baz(x) ::= buildq([x], x),
+ fboundp(baz));
+ true;
+ fboundp_maxima_macro(baz);
+ true;
+ *
+ */
+
+fboundp(a) :=
+ fboundp_operator(a)
+ or fboundp_simplifying(a)
+ or fboundp_ordinary_lisp(a)
+ or fboundp_quoting(a)
+ or fboundp_ordinary_maxima(a)
+ or fboundp_array_function(a)
+ or fboundp_maxima_macro(a);
+
+fboundp_operator(a) :=
+ stringp(a) and fboundp (verbify (a));
+
+fboundp_simplifying(a) :=
+ symbolp(a) and ?get(a, ?operators) # false;
+
+fboundp_ordinary_lisp(a) :=
+ symbolp(a) and ?fboundp(a) # false;
+
+fboundp_quoting(a) :=
+ symbolp(a) and ?get(a, ?mfexpr\*) # false;
+
+fboundp_ordinary_maxima(a) :=
+ symbolp(a) and ?mget(a, ?mexpr) # false;
+
+fboundp_array_function(a) :=
+ symbolp(a) and ?mget(a, ?aexpr) # false;
+
+fboundp_maxima_macro(a) :=
+ symbolp(a) and ?mget(a, ?mmacro) # false;
+
diff --git a/stack/2017121800/maxima/inequalities.mac b/stack/2023102700/maxima/inequalities.mac
similarity index 91%
rename from stack/2017121800/maxima/inequalities.mac
rename to stack/2023102700/maxima/inequalities.mac
index 1a2af9cf84bf637bf62d129e3f17ca9a5d09a19d..3ba94b9d8aee2f9bd1fc7fa58a23101676737057 100644
--- a/stack/2017121800/maxima/inequalities.mac
+++ b/stack/2023102700/maxima/inequalities.mac
@@ -29,6 +29,7 @@
ineqprepare(ex) := block([op2, ex2],
if mapatom(ex) then return(ex),
if safe_op(ex)="%not" then ex:not_ineq(first(args(ex))),
+ if mapatom(ex) then return(ex),
if op(ex)="=" then return(make_monic_eq(ev(part(ex,1) - part(ex,2), simp, trigreduce)) = 0),
if op(ex)=">" then return(make_monic(ev(part(ex,1) - part(ex,2), simp, trigreduce)) > 0),
if op(ex)=">=" then return(make_monic(ev(part(ex,1) - part(ex,2), simp, trigreduce)) >= 0),
@@ -41,14 +42,18 @@ ineqprepare(ex) := block([op2, ex2],
/* Turn a single variable polynomial expression into a +1/-1 monic polynomial.
This is used with inequalities. */
-make_monic(ex) := block([v,vc],
+make_monic(ex) := block([v,vc,nc],
if mapatom(ex) then return(ex),
if not(polynomialpsimp(ex)) then return(ex),
ex:expand(ex),
v:listofvars(ex),
if v=[] then return(ex),
- /* Divide by the numerical coefficient of the leading term, without losing the minus sign. */
- ev(expand(ex/abs(numerical_coeff(ex))), simp)
+ /* Divide by the numerical coefficient of the leading term, without losing the minus sign, where possible. */
+ nc:numerical_coeff(ex),
+ if not(is(nc=0)) then ex:ev(expand(ex/abs(nc)), simp),
+ /* Deal with one special case only here. */
+ if is(ex=first(v)-minf) then ex:first(v)+inf,
+ return(ex)
)$
/* Return the numerical coefficient of the leading term in expression. */
@@ -64,11 +69,12 @@ numerical_coeff(ex):= block([v, vc],
make_monic_eq(ex) := block([v],
if mapatom(ex) then return(ex),
if not(polynomialpsimp(ex)) then return(ex),
- ex:expand(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)
+ poly_normalize(ex, v)
)$
/* Determines if we have a linear inequality in one variable.
@@ -182,7 +188,7 @@ single_linear_ineq_reduce(ex, exo):=block([exg,exl],
*/
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."),
+ 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)))),
@@ -205,6 +211,14 @@ linear_inequality_to_interval(ex) := block([ex2, v, p, Ans],
if not(linear_inequalityp(ex)) then return(ex),
ex2:ineqprepare(ex),
v:first(listofvars(ex2)),
+ /* Deal with edge cases involving infinity. */
+ if is(lhs(ex2)=v-inf) then return({}),
+ if is(ex2=(inf-v>0)) then return(all),
+ if is(ex2=(inf-v>=0)) then return(oc(minf,inf)),
+ if is(lhs(ex2)=v+minf) then return({}),
+ if is(ex2=(v+inf>0)) then return(all),
+ if is(ex2=(v+inf>=0)) then return(co(minf,inf)),
+
/* We know this solution will exist. */
p:rhs(first(solve(lhs(ex2), v))),
/* But we can only create an interval if the value is real! */
@@ -212,13 +226,13 @@ linear_inequality_to_interval(ex) := block([ex2, v, p, Ans],
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 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)
+ if op(ex2)=">" then Ans:oo(-inf, p),
+ if op(ex2)=">=" then Ans:oc(-inf, p)
),
return(Ans)
)$
@@ -226,10 +240,14 @@ linear_inequality_to_interval(ex) := block([ex2, v, p, 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],
+inequality_factor_solve(ex):=block([ex2, p],
if not(inequalityp(ex)) then return(ex),
if length(listofvars(ex))#1 then return(ex),
ex:ineqprepare(ex),
+
+ /* Don't try to solve inequalities with inf/minf etc. */
+ if not(freeof(inf, ex)) or not(freeof(minf,ex)) then return(ex),
+
if not(polynomialp(lhs(ex), listofvars(ex))) then return(ex),
exop:op(ex), /* This is for >, >= */
diff --git a/stack/2023102700/maxima/intervals.mac b/stack/2023102700/maxima/intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1050b4bc767ea29e744fa21c425431638a2bf22f
--- /dev/null
+++ b/stack/2023102700/maxima/intervals.mac
@@ -0,0 +1,942 @@
+/* Author Chris Sangwin
+ University of Edinburgh
+ Copyright (C) 2020 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+
+/********************************************************************/
+/* A package for manipulating intervals in Maxima. */
+/* Based on code by Matthew James Read, 2012. */
+/* Re-written, May 2020. Chris Sangwin, <C.J.Sangwin@ed.ac.uk> */
+/* */
+/* V1.0 May 2020 */
+/* */
+/********************************************************************/
+
+/* Deal with unions. */
+
+unionp(ex) := if safe_op(ex)="%union" or safe_op(ex)="union" then true else false;
+
+intersectionp(ex) := if safe_op(ex)="%intersection" then true else false;
+
+/* Define simple intervals. */
+
+/* Defines the check functions for when intervals are entered: */
+cc_num(x,y) := block([Ans],
+ Ans: 'cc(x,y), /* Makes Ans equal to the original interval. Note the ' to stop evaluation or else it would create an infinite loop. */
+ if not ev(real_numberp(x), simp) then /* Checks x is a real number. */
+ error("intervals: ",x," should be a real number"),
+ if not ev(real_numberp(y), simp) then /* Checks y is a real number. */
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{}, /* Our interval is the empty set if y<x. */
+ if x=y then Ans:{x}, /* Simply the set {x} is x=y. */
+ Ans
+)$
+
+oo_num(x,y) := block([Ans],
+ Ans: 'oo(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf ), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y) and not(y=inf or y=-inf ), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+co_num(x,y) := block([Ans],
+ Ans: 'co(x,y),
+ if ev(not real_numberp(x), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev((not real_numberp(y) and not(y=inf or y=-inf)), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+oc_num(x,y) := block([Ans],
+ Ans: 'oc(x,y),
+ if ev(not real_numberp(x) and not(x=inf or x=-inf), simp) then
+ error("intervals: ",x," should be a real number"),
+ if ev(not real_numberp(y), simp) then
+ error("intervals: ",y," should be a real number"),
+ if y<x then Ans:{},
+ if x=y then Ans:{},
+ Ans
+)$
+
+/* Validate student's input. */
+
+/* Return a list of errors for a single connected component. */
+interval_validate_single_interval(ex) := block([ret, iop, il, ir],
+ ret:"",
+ if trivialintervalp(ex) then return(""),
+ if not(intervalp(ex)) then
+ return(StackAddFeedback("", "Interval_notinterval", stack_disp(ex, "i"))),
+ if not(is(length(args(ex))=2)) then
+ /* The tex functions only cope with two arguments, so we have to use a string here! */
+ return(StackAddFeedback("", "Interval_wrongnumargs", stack_disp(string(ex), "i"))),
+ iop:op(ex),
+ il:first(args(ex)),
+ ir:second(args(ex)),
+ if real_numberp(il) and real_numberp(ir) and is(ir<il) then
+ ret:StackAddFeedback(ret, "Interval_backwards", stack_disp(ex, "i"), stack_disp(apply(iop,[ir, il]), "i")),
+ return(ret)
+)$
+
+/* Validate a realset, mostly for student feedback, so no errors thrown. */
+interval_validate_realset(ex) := block(
+ if trivialintervalp(ex) then return(""),
+ if setp(ex) then return(""),
+ if intervalp(ex) then return(interval_validate_single_interval(ex)),
+ if safe_op(ex)="%union" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ if safe_op(ex)="%intersection" then return(apply(sconcat, maplist(interval_validate_realset, args(ex)))),
+ return(StackAddFeedback("", "Interval_illegal_entries", stack_disp(ex, "i")))
+)$
+
+cc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right]")
+)$
+texput(cc, cc_interval_tex)$
+
+/* Note, the mismatching square brackets play havoc with the PHP interface. */
+co_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left[ ", tex1(a),",\\, ",tex1(b), "\\right)")*/
+ concat("!LEFTSQ! ", tex1(a),",\\, ",tex1(b), "!RIGHTR!")
+)$
+texput(co, co_interval_tex)$
+
+oc_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ /*concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right]")*/
+ concat("!LEFTR! ", tex1(a),",\\, ",tex1(b), "!RIGHTSQ!")
+)$
+texput(oc, oc_interval_tex)$
+
+oo_interval_tex(ex) := block([a, b],
+ a:first(args(ex)),
+ b:second(args(ex)),
+ concat("\\left( ", tex1(a),",\\, ",tex1(b), "\\right)")
+)$
+texput(oo, oo_interval_tex)$
+
+realset_tex(ex) := block([a, b, c],
+ if not(length(args(ex))=2) then error("realset: this function must have two arguments."),
+ a:first(args(ex)),
+ b:second(args(ex)),
+ c:ev(interval_complement(b), simp),
+ if safe_setp(c) then
+ concat("{", tex1(a), " \\not\\in {",tex1(c), "}}")
+ else
+ concat("{", tex1(a), " \\in {",tex1(b), "}}")
+)$
+texput(realset, realset_tex)$
+
+/* Returns True if p is an element of A. False, otherwise: */
+
+inintervalp(p, A) := block ([Ans, Args, x, y, Atemp, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ Ans:false,
+ if not ev(real_numberp(p), simp) then
+ error("intervals: ",p," should be a real number"),
+
+ if atom(A) then Ans:false
+ elseif op(A)=set then
+ (
+ Atemp:listify(A),
+ n:length(Atemp),
+ while i<(n+1) do
+ (
+ if p=Atemp[i] then Ans:true,
+ i:i+1 )
+ )
+ elseif not( op(A)="[" ) then
+ (
+ Args:args(A),
+ x:first(Args),
+ y:last(Args),
+ if op(A)=cc then
+ (
+ if (p>=x and p<=y) then Ans:true
+ ),
+ if op(A)=oo then
+ (
+ if (p>x and p<y) then Ans:true
+ ),
+ if op(A)=co then
+ (
+ if (p>=x and p<y) then Ans:true
+ ),
+ if op(A)=oc then
+ (
+ if (p>x and p<=y) then Ans:true
+ )
+ )
+ elseif op(A)="[" then
+ (
+ n:length(A),
+ while j<n+1 do
+ (
+ Atemp:A[j],
+ Ans:inintervalp(p,Atemp),
+ if Ans=false then j:j+1 else j:n+1
+ )
+ )
+ else error("intervals: the interval, ",A,", is not of a recognised form"),
+ Ans
+)$
+
+intervalp(X) := if (safe_op(X)="cc" or safe_op(X)="oo" or safe_op(X)="oc" or safe_op(X)="co") then true else false$
+
+realsetp(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(all_listp(real_numberp, args(ex))),
+ if intervalp(ex) then return(all_listp(extended_real_numberp, args(ex))),
+ if op(ex)=%union then return(all_listp(realsetp, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realsetp, args(ex))),
+ return(false)
+)$
+
+/* Does not require all numbers to be actual real numbers. */
+realset_soft_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=realset then return(true),
+ if op(ex)=%union then return(all_listp(realset_soft_p, args(ex))),
+ if op(ex)=%intersection then return(all_listp(realset_soft_p, args(ex))),
+ return(false)
+)$
+
+/* Only looks at the very top level, used for validation */
+realset_surface_p(ex) := block(
+ if is(ex=all) then return(true),
+ if is(ex=none) then return(true),
+ if atom(ex) then return(false),
+ if safe_setp(ex) then return(true),
+ if intervalp(ex) then return(true),
+ if op(ex)=%union then return(true),
+ if op(ex)=%intersection then return(true),
+ return(false)
+)$
+
+/* Make a real set, taking edge cases into account. This is also a top level function to convert true/false into all/none. */
+realsetmake(v, ex) := block(
+ if is(ex=false) then return(none),
+ if is(ex={}) then return(none),
+ if is(ex=%union()) then return(none),
+ if is(ex=%intersection()) then return(none),
+ if is(ex=true) then return(all),
+ if is(ex=all) or is(ex=none) or is(ex=unknown) then return(ex),
+ if atom(ex) then return(ex),
+ if is(safe_op(ex)="realset") then return(ex),
+ if not(realset_soft_p(ex)) then error("realsetmake: second argument must appear to be a real set."),
+ return(realset(v, ex))
+)$
+
+/* Predicate to remove trivial cases like oo(a,a) and co(-inf, -inf). */
+trivialintervalp(ex) := block(
+ if is(ex=all) or is(ex=none) then return(true),
+ if safe_setp(ex) and ex={} then return(true),
+ if not(intervalp(ex)) then return(false),
+ if safe_op(ex)="oo" and first(ex)=second(ex) then return(true),
+ if safe_op(ex)="oc" and first(ex)=second(ex) then return(true),
+ if safe_op(ex)="co" and first(ex)=second(ex) then return(true),
+ if first(ex)=inf then return(true),
+ if second(ex)=-inf then return(true),
+ return(false)
+)$
+
+/* Return the number of separate connected components. */
+interval_count_components(ex) := block(
+ if not(realsetp(ex)) then error("interval_count_components"),
+ if ex=all then return(1),
+ if trivialintervalp(ex) then return(0),
+ if intervalp(ex) then return(1),
+ if setp(ex) then return(cardinality(ex)),
+ ev(apply("+", map(interval_count_components, args(ex))), simp)
+)$
+
+interval_simple_union(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, j:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if A=all then return(all),
+ if B=all then return(all),
+ if A=none or A={} then return(B),
+ if B=none or B={} then return(A),
+
+ if atom(A) then error("interval_simple_union: invalid first argument"),
+ if atom(B) then error("interval_simple_union: invalid second argument"),
+
+ if safe_setp(A) then (
+ if safe_setp(B) then
+ Ans:union(A,B)
+ else (
+ Args1:args(B),
+ x1:first(Args1),
+ y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if (Aset[i]<x1 or Aset[i]>y1) then
+ setAns:cons(Aset[i],setAns)
+ elseif Aset[i]=x1 then (
+ if op(B)=oc then B:cc(x1,y1),
+ if op(B)=oo then B:co(x1,y1)
+ )
+ elseif Aset[i]=y1 then (
+ if op(B)=co then B:cc(x1,y1),
+ if op(B)=oo then B:oc(x1,y1)
+ ),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans: [B,setAns] ) else Ans:B
+ )
+ )
+ elseif safe_setp(B) then (
+ Args1:args(A),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(B),
+ n:length(Aset),
+ while i<(n+1) do (
+ if (Aset[i]<x1 or Aset[i]>y1) then
+ setAns:cons(Aset[i],setAns)
+ elseif Aset[i]=x1 then (
+ if op(A)=oc then A:cc(x1,y1),
+ if op(A)=oo then A:co(x1,y1)
+ )
+ elseif Aset[i]=y1 then (
+ if op(A)=co then A:cc(x1,y1),
+ if op(A)=oo then A:oc(x1,y1)
+ ),
+ i:i+1
+ ),
+ if length(setAns)>0 then (setAns:setify(setAns), Ans: [A,setAns] ) else Ans:A
+ ),
+
+ if ( not atom(A) and not atom(B) ) then (
+ Args1:args(A),
+ Args2:args(B),
+
+ if not(atom(A) or safe_setp(A) or atom(B) or safe_setp(B)) then (
+ if first(Args1)<first(Args2) then
+ swap:false,
+ if first(Args1)=first(Args2) then (
+ if ( op(A)=co or op(A)=cc ) then
+ swap:false
+ elseif ( op(B)=co or op(B)=cc ) then
+ swap:true
+ else swap:false
+ ),
+ if first(Args1)>first(Args2) then swap:true,
+ if swap=false then (
+ x1:first(Args1),
+ y1:last(Args1),
+ x2:first(Args2),
+ y2:last(Args2)
+ ) else (
+ Atemp:A,
+ A:B,
+ B:Atemp,
+ x2:first(Args1),
+ y2:last(Args1),
+ x1:first(Args2),
+ y1:last(Args2)
+ ),
+ if x2>y1 then
+ Ans:[A,B],
+ if (x2<y1 and y2>y1) then (
+ if (op(A)=cc or op(A)=co) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:cc(x1,y2)
+ elseif (op(B)=oo or op(B)=co) then
+ Ans:co(x1,y2)
+ )
+ elseif (op(A)=oc or op(A)=oo) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:oc(x1,y2)
+ elseif (op(B)=oo or op(B)=co) then
+ Ans:oo(x1,y2)
+ )
+ ),
+ if (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:interval_simple_union( A , {y2} )
+ else
+ Ans:A
+ ),
+ if (x2<y1 and y2<y1) then
+ Ans:A,
+ if x2=y1 then (
+ if ( (op(A)=co or op(A)=oo) and (op(B)=oo or op(B)=oc) ) then
+ Ans:[A,B]
+ else (
+ if (op(A)=cc or op(A)=co) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:cc(x1,y2)
+ elseif (op(B)=oo or op(B)=co) then
+ Ans:co(x1,y2)
+ )
+ elseif (op(A)=oc or op(A)=oo) then (
+ if (op(B)=oc or op(B)=cc) then
+ Ans:oc(x1,y2)
+ elseif (op(B)=oo or op(B)=co) then
+ Ans:oo(x1,y2)
+ )
+ )
+ )
+ )
+ ),
+ Ans
+)$
+
+
+/* Finds the intersection of two "simple" real sets. */
+interval_simple_intersect(X,Y) := block([A:X, B:Y, Ans, x1, x2, y1, y2, Args1, Args2, Aset, swap:false, lopen:false, ropen:false, setAns:[], cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), i:1, n],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if not(realsetp(X)) then error("interval_simple_intersect expects its first argument to be a real set."),
+ if not(realsetp(Y)) then error("interval_simple_intersect expects its second argument to be a real set."),
+
+ if safe_setp(A) and safe_setp(B) then return(intersect(A,B)),
+ /* A & B are not both sets. */
+ if safe_setp(B) then (
+ A:Y,
+ B:X
+ ),
+ if safe_setp(A) then (
+ Args1:args(B),
+ x1:first(Args1), y1:last(Args1),
+ Aset:listify(A),
+ n:length(Aset),
+ while i<(n+1) do (
+ if inintervalp(Aset[i],B) then setAns:cons(Aset[i],setAns),
+ i:i+1
+ ),
+ if length(setAns)>0 then (
+ setAns:setify(setAns),
+ Ans:setAns
+ ) else (
+ Ans:{}
+ ),
+ return(Ans)
+ ),
+ /* At this point we have both A & B not sets. */
+ if not(intervalp(A) and intervalp(B)) then error("interval_simple_intersect expects its arguments to be sets or simple intervals."),
+
+ Args1:args(A),
+ Args2:args(B),
+
+ if first(Args1)<first(Args2) then
+ swap:false,
+ if first(Args1)=first(Args2) then (
+ if (op(A)=co or op(A)=cc) then (
+ swap:false
+ ) elseif (op(B)=co or op(B)=cc ) then (
+ swap:true
+ ) else (
+ swap:false
+ )
+ ),
+ if is(first(Args1)>first(Args2)) then (
+ swap:true
+ ),
+
+ if swap=false then (
+ x1:first(Args1),
+ y1:last(Args1),
+ x2:first(Args2),
+ y2:last(Args2)
+ ) else (
+ Atemp:A,
+ A:B,
+ B:Atemp,
+ x2:first(Args1),
+ y2:last(Args1),
+ x1:first(Args2),
+ y1:last(Args2)
+ ),
+ if x2>y1 then (
+ Ans:{}
+ ),
+ if (x2<y1 and y2>y1) then (
+ if (op(A)=cc or op(A)=oc) then (
+ if (op(B)=cc or op(B)=co) then
+ Ans:cc(x2,y1)
+ elseif (op(B)=oo or op(B)=oc) then
+ Ans:oc(x2,y1)
+ ) elseif (op(A)=co or op(A)=oo) then (
+ if (op(B)=co or op(B)=cc) then
+ Ans:co(x2,y1)
+ elseif (op(B)=oo or op(B)=oc) then (
+ Ans:oo(x2,y1)
+ )
+ )
+ ),
+ if (x2<y1 and y2<y1) then
+ Ans:B,
+ if (x2<y1 and y2=y1) then (
+ if (op(B)=oc or op(B)=oo) then lopen:true,
+ if (op(B)=oo or op(B)=co or op(A)=oo or op(A)=co) then ropen:true,
+ if (lopen and ropen) then Ans:oo(x2,y1),
+ if (lopen and not ropen) then Ans:oc(x2,y1),
+ if (not lopen and ropen) then Ans:co(x2,y1),
+ if (not lopen and not ropen) then Ans:cc(x2,y1)
+ ),
+ if x2=y1 then (
+ if ((op(A)=cc or op(A)=oc) and (op(B)=co or op(B)=cc)) then
+ Ans:{x2}
+ else
+ Ans:{}
+ ),
+ Ans
+)$
+
+interval_disjointp(A, B) := if interval_simple_intersect(A, B)={} then true else false$
+
+/* Is the ex1 contained within the real set ex2? */
+interval_subsetp(ex1, ex2) := block(
+ if not(realsetp(ex1)) then error("interval_subsetp expects its first argument to be a real set."),
+ if not(realsetp(ex2)) then error("interval_subsetp expects its second argument to be a real set."),
+ if interval_intersect(ex1, ex2) = ex1 then true else false
+)$
+
+/* Is the simple interval ex a explicitly a subinterval of EX? */
+interval_containsp(ex, EX) := block(
+ if not(intervalp(ex)) then error("interval_containsp expects its first argument to be a simple interval."),
+ if not(realsetp(EX)) then error("interval_containsp expects its second argument to be a real set."),
+ if is(ex=EX) then return(true),
+ if not(safe_op(EX)="%union" or safe_op(EX)="%intersection") then return(false),
+ if elementp(ex,setify(args(EX))) then return(true),
+ return(false)
+)$
+
+/* Top level intersection function which takes real sets, such as %unions. */
+interval_intersect(X,Y) := block([A, B, Ans:[], temp, m, n, i:1, j:1],
+ A:X,
+ B:Y,
+
+ if safe_op(A)="%intersection" then A:interval_intersect_list(args(A)),
+ if safe_op(B)="%intersection" then B:interval_intersect_list(args(B)),
+
+ if is(A=all) then return(B),
+ if is(B=all) then return(A),
+ if atom(A) then return({}),
+ if atom(B) then return({}),
+ if is(A={}) then return({}),
+ if is(B={}) then return({}),
+
+ if op(A)=%union then A:args(A),
+ if op(B)=%union then B:args(B),
+ if not(listp(A)) and not(listp(B)) then return(interval_simple_intersect(A,B)),
+
+ /* Ensure we have lists to deal with, by making them lists of one element if needed. */
+ if not(listp(A)) then (temp:[], A:cons(A,temp) ),
+ if not(listp(B)) then (temp:[], B:cons(B,temp) ),
+
+ m:length(A),
+ n:length(B),
+ if (m=1 and n=1) then (
+ A:A[1],
+ B:B[1],
+ return(interval_simple_intersect(A,B))
+ ) else (
+ while i<m+1 do (
+ while j<n+1 do (
+ temp:interval_simple_intersect(A[i], B[j]),
+ if not atom(temp) then (
+ Ans:append(Ans, [temp])
+ ),
+ j:j+1
+ ),
+ j:1,
+ i:i+1
+ )
+ ),
+ if listp(Ans) then (
+ if length(Ans)=1 then Ans:Ans[1],
+ if length(Ans)=0 then Ans:{}
+ ),
+ interval_tidy(Ans)
+)$
+
+/* Given a *list* of intervals, returns the intersection of all of them. */
+interval_intersect_list(X) :=
+ block ( [A:X, Ans, n, i, simp],
+ simp:true,
+ if X=[] then return({}),
+ n:length(A),
+ if n=1 then return(first(A)),
+ Ans:A[1],
+ i:2,
+ while i<n+1 do
+ (
+ Ans:interval_intersect(Ans, A[i]),
+ i:i+1
+ ),
+ Ans
+ );
+
+interval_intersect_nary([X]) := interval_intersect_list(X)$
+
+/* Given intervals, returns the same intervals but in ascending order of the first element in the interval. */
+interval_sort(X) := block([A:X, Ans:[], x, n, i],
+ if safe_op(X) = "%union" then A:args(X),
+
+ n:length(A),
+ while n>0 do
+ (
+ x:A[1],
+ i:2,
+ while i<n+1 do block(
+ if is(first(A[i]) < first(x)) then x:A[i],
+ i:ev(i+1,simp)
+ ),
+ Ans:append(Ans,[x]),
+ A:delete(x, A, 1),
+ n:ev(n-1, simp)
+ ),
+ /* %union does things to its arguments like moving -inf to the right with simp:true. */
+ /* Return a list to avoid killing the order here. */
+ Ans
+);
+
+/* Given a union of disjoint intervals,
+ checks whether any intervals are connected, and if so, joins them up and returns the ammended union. */
+interval_connect(X) := block([Ans, n, x, y, i:1],
+ if not(op(X)=%union or listp(X)) then error("interval_connect requires a %union or list of intervals"),
+ Ans:args(X),
+ n:length(Ans),
+ while i<n do
+ (
+ i:ev(i,simp),
+ if last( Ans[i] ) >= first( Ans[ev(i+1, simp)] ) then
+ (
+ x:interval_simple_union( Ans[i], Ans[ev(i+1, simp)] ),
+ if ( not op(x) = "[" ) then
+ (
+ Ans:delete( Ans[ev(i+1, simp)], Ans, 1 ),
+ Ans:delete( Ans[i], Ans, 1 ),
+ Ans:append( Ans, [x] ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ )
+ ),
+ i:i+1
+ ),
+ if length(Ans) = 1 then return(Ans[1]),
+ Ans:apply(%union, Ans),
+ Ans
+);
+
+/* Given a union of disjoint sets, returns the "canonical form" of this union: */
+interval_tidy(X) := block([A, Ans:[], n, setpart:{}, x, y, i:1],
+ if X=all then return(all),
+ if atom(X) then return(Ans:phi),
+ if listp(X) then X:apply(%union, X),
+ X:ev(X, %intersection=interval_intersect_nary),
+
+ if not(op(X)=%union or listp(X)) then (
+ Ans:X
+ ) else (
+ A:args(X),
+ i:1,
+ n:length(A),
+ while i<ev(n+1, simp) do (
+ i:ev(i,simp),
+ if safe_setp(A[i]) then (
+ setpart:union(setpart, A[i] ),
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ) else if trivialintervalp(A[i]) then (
+ A:delete( A[i], A, 1 ),
+ i:ev(i-1, simp),
+ n:ev(n-1, simp)
+ ),
+ i:ev(i+1, simp)
+ ),
+ A:interval_sort(A),
+ if is(length(A)>1) then
+ A:interval_connect(A),
+ if length(setpart)>0 then A:append( args(A), [setpart] ),
+ if is(A=[]) then
+ A:{}
+ elseif is(length(A)=1) then
+ A:first(A),
+ Ans:A
+ ),
+ if Ans=oo(-inf,inf) then return(all),
+ Ans
+)$
+
+interval_complement_order_points(X):=
+ block( [A:X, Ans:[], setpart, n, i:1],
+ A:interval_tidy(A),
+ if safe_setp(last(A)) then (
+ setpart:listify(last(A)),
+ A:delete(last(A), A, 1),
+ n:length(A) + length(setpart),
+
+ while i<n+1 do
+ (
+ if length(setpart)>0 then
+ (
+ if length(A)=0 then
+ (
+ Ans:append( Ans, [ { setpart[1] } ] ),
+ setpart:delete( setpart[1], setpart, 1 )
+ )
+ else
+ (
+ if setpart[1] < first( A[1] ) then
+ (
+ Ans:append( Ans, [ { setpart[1] } ] ),
+ setpart:delete( setpart[1], setpart, 1 )
+ )
+ else
+ (
+ Ans:append( Ans, [ A[1] ] ),
+ A:delete( A[1], A, 1 )
+ )
+ )
+ ),
+ i:i+1
+ )
+ )
+ else Ans:A,
+ Ans
+)$
+
+/* Return the set complement of a real set. */
+interval_complement(X):= block([A:X, Ans:[], x, y, cc:cc(0,1), oo:oo(0,1), co:co(0,1), oc:oc(0,1), n, i:1],
+ cc:op(cc), oo:op(oo), co:op(co), oc:op(oc),
+
+ if atom(A) then return(oo(-inf,inf)),
+ if not (op(A) = "[" or op(A)=%union) then (
+ if safe_setp(A) then Ans:interval_set_complement(A)
+ elseif intervalp(A) then (
+ if op(A)=co then
+ (
+ Ans:append( Ans, [ oo(-inf, first(A) ) ] ),
+ Ans:append( Ans, [ co( last(A), inf) ] )
+ ),
+ if op(A)=cc then
+ (
+ Ans:append( Ans, [ oo(-inf, first(A) ) ] ),
+ Ans:append( Ans, [ oo( last(A), inf) ] )
+ ),
+ if op(A)=oc then
+ (
+ Ans:append( Ans, [ oc(-inf, first(A) ) ] ),
+ Ans:append( Ans, [ oo( last(A), inf) ] )
+ ),
+ if op(A)=oo then
+ (
+ Ans:append( Ans, [ oc(-inf, first(A) ) ] ),
+ Ans:append( Ans, [ co( last(A), inf) ] )
+ )
+ )
+ ) else (
+ A:interval_complement_order_points(A),
+ A:args(A),
+
+ /* Just use DeMorgan's laws. */
+ Ans:ev(interval_intersect_list(maplist(lambda([ex2], interval_tidy(interval_complement(ex2))), A)), simp),
+
+ if listp(Ans) and length(Ans)=1 then
+ Ans:Ans[1]
+ ),
+ if listp(Ans) then
+ Ans:apply(%union, Ans),
+ Ans
+)$
+
+/* Take a set of real numbers, and return the %union of intervals not containing these numbers. */
+interval_set_complement(X):= block([A:X, Ans:[], temp, n, i:1],
+ if not(setp(X)) then error("interval_set_complement requires a set."),
+ A:listify(A),
+ n:length(A),
+ temp:oo(-inf, A[1]),
+ Ans:[temp],
+ while i<n do (
+ temp:oo( A[i], A[i+1] ),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ i:i+1
+ ),
+ temp:oo(A[n], inf),
+ temp:[temp],
+ Ans:append(Ans, temp),
+ apply(%union, Ans)
+)$
+
+
+
+/* Turns a single variable system over the reals into 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:stack_noteq_single_remove(ex),
+ ex:subst("%and", "nounand", ex),
+ ex:subst("%or", "nounor", ex),
+ /* %not is not an infix operator... */
+ ex:subst(%not, "not", ex),
+ ex:subst(%not, "nounnot", ex),
+ ex:subst("%and", "and", ex),
+ ex:subst("%or", "or", ex),
+
+ /* Notes,
+ (1) assume_pos automatically removes terms like v>=0 in the simplifier.
+ (2) we do need simplification here to reduce execution time.
+ */
+
+ if assume_pos then
+ ex:block([assume_pos:false], ev(single_variable_solver_real_rec(ex %and (v>=0), v), simp))
+ else
+ ex:ev(single_variable_solver_real_rec(ex, v), simp),
+
+ if ((safe_op(ex)="[" or safe_op(ex)="%union") and is(length(args(ex))=1)) then ex:first(ex),
+
+ if is(ex={}) then return(none),
+ if is(ex={v}) then return(all),
+ if logic_edgep(ex) then return(ex),
+ if is(equal(ex,oo(-inf,inf))) then return(all),
+
+ rs1:ex,
+ rs2:false,
+ if safe_op(ex)="%or" then block(
+ rs1:ev(sublist(args(ex), realset_soft_p), simp),
+ rs2:ev(sublist(args(ex), lambda([ex2], not realset_soft_p(ex2))), simp),
+ if is(length(rs1)=1) then rs1:first(rs1),
+ if is(rs1=none) then
+ ex:apply("%or", rs2)
+ else if is(rs1=all) then
+ ex:all
+ else
+ ex:(if realset_soft_p(rs1) then realsetmake(v, rs1) else rs1) %or apply("%or", rs2)
+ ),
+ if safe_op(ex)="%union" or safe_setp(ex) then
+ ex:realsetmake(v, ex),
+
+ return(ex)
+)$
+
+single_variable_solver_real_rec(ex, v) := block([r0, r1, r2],
+ if atom(ex) then return(ex),
+ if intervalp(ex) then return(ex),
+ /* Equations should look real. */
+ if not(freeof(%i,ex)) then return(ex),
+
+ if equationp(ex) then ex:subst("%or", "nounor", pm_replace(ex)),
+ if equationp(ex) then return(ev(equation_to_intervals(ex, v), simp)),
+ if linear_inequalityp(ex) then return(ev(linear_inequality_to_interval(ex), simp)),
+
+ /* Possible recursion from here. */
+ if inequalityp(ex) then ex:ev(inequality_factor_solve(ex), simp),
+
+ if safe_op(ex)="%or" or safe_op(ex)="%and" then block(
+ r0:maplist(lambda([ex2], single_variable_solver_real_rec(ex2, v)), args(ex)),
+ r1:ev(sublist(r0, realset_soft_p), simp),
+ r2:ev(sublist(r0, lambda([ex2], not(realset_soft_p(ex2)))), simp)
+ ),
+ if safe_op(ex)="%or" then return(ev(apply("%or", append([interval_tidy(r1)], r2)), simp)),
+ if safe_op(ex)="%and" then return(ev(apply("%and", append([interval_intersect_list(r1)], r2)), simp)),
+
+ return(ex)
+)$
+
+equation_to_intervals(ex, v) := block([sol0, sol1, sol2],
+ sol0:radcan(solve(ex, v)),
+ if sol0=[] then return({}),
+ if logic_edgep(sol0) then return(sol0),
+ /* We need the "freeof" clause to catch rearrangements of equations. */
+ sol1:sublist(sol0, lambda([ex2], is(lhs(ex2)=v) and freeof(v, rhs(ex2)))),
+ sol2:sublist(sol0, lambda([ex2], not(is(lhs(ex2)=v) and freeof(v, rhs(ex2))))),
+ sol1:maplist(rhs,sol1),
+ 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),
+ if realset_soft_p(ex2) then ex2:realsetmake(v, ex2),
+ ex2
+)$
+
+/* Calculate the natural domain of a single-variable term. */
+natural_domain_rec(ex) := block([v, ex2],
+ if atom(ex) then return(all),
+ v:listofvars(ex),
+ if is(v=[]) then return(all),
+ if not(is(length(v)=1)) then return(unknown),
+ v:first(v),
+
+ if safe_op(ex)="sqrt" then
+ return(single_variable_solver_real(first(args(ex))>=0)),
+ if safe_op(ex)="ln" or safe_op(ex)="log" or safe_op(ex)="lg" then
+ return(single_variable_solver_real(first(args(ex))>0)),
+ if safe_op(ex)="/" then
+ ex2:[natural_domain_rec(first(args(ex))), single_variable_solver_real((second(args(ex))>0) %or (second(args(ex))<0))]
+ else
+ ex2:map(natural_domain_rec, args(ex)),
+ /* We have to strip of the realset bit before intersecting. */
+ ex2:map(lambda([ex3], if is(safe_op(ex3)="realset") then second(ex3) else ex3), ex2),
+ /* Only return a define value if we really have one. */
+ if any_listp(lambda([ex3], is(ex3=unknown) or not(realset_soft_p(ex3) or is(ex3=true) or is(ex3=false))), ex2) then
+ ex2:unknown
+ else
+ ex2:interval_intersect_list(ex2),
+ ex2
+)$
diff --git a/stack/2023102700/maxima/local.mac b/stack/2023102700/maxima/local.mac
new file mode 100644
index 0000000000000000000000000000000000000000..dda3e0467a5c4f434e496ae1ed1b8cc3381c6e8e
--- /dev/null
+++ b/stack/2023102700/maxima/local.mac
@@ -0,0 +1 @@
+/* Site-specific Maxima code can be put here. */
diff --git a/stack/2023102700/maxima/noun_arith.lisp b/stack/2023102700/maxima/noun_arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..902c17600a3019c2a42eb2dd1171ad311db13e52
--- /dev/null
+++ b/stack/2023102700/maxima/noun_arith.lisp
@@ -0,0 +1,53 @@
+;; Customize Maxima's tex() function.
+;; Chris Sangwin 21 Oct 2005.
+;; Useful files:
+;; \Maxima-5.9.0\share\maxima\5.9.0\share\utils\mactex-utilities.lisp
+;; \Maxima-5.9.0\share\maxima\5.9.0\src\mactex.lisp
+
+(defprop $nounadd tex-mplus tex)
+(defprop $nounadd ("+") texsym)
+(defprop $nounadd 100. tex-lbp)
+(defprop $nounadd 100. tex-rbp)
+
+(defprop $nounsub tex-prefix tex)
+(defprop $nounsub ("-") texsym)
+(defprop $nounsub 100. tex-rbp)
+(defprop $nounsub 100. tex-lbp)
+
+(defprop $nounmul tex-nary tex)
+(defprop $nounmul "\\," texsym)
+(defprop $nounmul 120. tex-lbp)
+(defprop $nounmul 120. tex-rbp)
+
+(defprop $noundiv tex-mquotient tex)
+(defprop $noundiv 122. tex-lbp) ;;dunno about this
+(defprop $noundiv 123. tex-rbp)
+
+(defprop $nounpow tex-mexpt tex)
+(defprop $nounpow 140. tex-lbp)
+(defprop $nounpow 139. tex-rbp)
+
+(defprop $nounand tex-nary tex)
+;;(defprop $nounand ("\\land ") texsym)
+(defprop $nounand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+(defprop $nounand 65. tex-lbp)
+(defprop $nounand 65. tex-rbp)
+;;(defprop mand ("\\land ") texsym)
+(defprop mand ("\\,{\\mbox{ !AND! }}\\, ") texsym)
+
+(defprop $nounor tex-nary tex)
+;;(defprop $nounor ("\\lor ") texsym)
+(defprop $nounor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+(defprop $nounor 61. tex-lbp)
+(defprop $nounor 61. tex-rbp)
+;;(defprop mor ("\\lor ") texsym)
+(defprop mor ("\\,{\\mbox{ !OR! }}\\, ") texsym)
+
+(defprop $nounnot tex-prefix tex)
+;;(defprop $nounnot ("\\neg ") texsym)
+(defprop $nounnot ("{\\rm !NOT!}") texsym)
+(defprop $nounnot 70. tex-lbp)
+(defprop $nounnot 70. tex-rbp)
+(defprop mnot tex-prefix tex)
+;;(defprop mnot ("\\neg ") texsym)
+(defprop mnot ("{\\rm !NOT!}") texsym)
\ No newline at end of file
diff --git a/stack/2023102700/maxima/noun_simp.mac b/stack/2023102700/maxima/noun_simp.mac
new file mode 100644
index 0000000000000000000000000000000000000000..326374cb1219562943ee12c2ec893207c52fab1c
--- /dev/null
+++ b/stack/2023102700/maxima/noun_simp.mac
@@ -0,0 +1,671 @@
+/* Author Chris Sangwin
+ University of Edinburgh
+ Copyright (C) 2021 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* ********************************** */
+/* Noun arithmetic */
+/* ********************************** */
+
+/*
+ These function define arithmetic functions which do
+ not perform their actual mathematical functions. That is to say
+ noun forms of the standard arithmetic functions. This is to
+ give much finer control over the simplification of very elementary
+ expressions.
+
+ Chris Sangwin 21 Oct 2005.
+ Chris Sangwin 7 Nov 2009, with help from JHD.
+ Chris Sangwin April 2021, add finer control.
+*/
+
+/* Create noun forms of the functions of +, -, *, / and ^
+ as follows.
+ + nounadd
+ - nounsub
+ * nounmul
+ / noundiv
+ ^ nounpow
+ = nouneq
+*/
+
+/* For each of these we do the following.
+ (1) They are defined as infix and nary operators in Maxima
+ with the binding precedences of their namesakes.
+ (2) The tex() function is modified to display them exactly as
+ their namesakes. This should work with a *mix* of noun and
+ active operators.
+ (3) verb_arith(expr) which will replace noun versions with their
+ active counterparts.
+ (4) noun_arith(expr) which will replace arithmetic operators with their
+ noun counterparts.
+*/
+
+/* (1) */
+nary("nouneq", 150);
+nary("nounadd", 100);
+prefix("nounsub", 100);
+nary("nounmul", 120);
+infix("noundiv", 122, 123);
+infix("nounpow", 140, 139);
+prefix("UNARY_RECIP", 100);
+
+declare("nounmul", commutative);
+declare("nounadd", commutative);
+
+/* (2) */
+load("noun_arith.lisp");
+
+/* (3) */
+declare("nouneq", commutative);
+declare("nouneq", lassociative);
+declare("nouneq", rassociative);
+
+verb_arith(ex) := block([a],
+ ex:subst("=", "nouneq", ex),
+ ex:subst("+", "nounadd", ex),
+ ex:subst("*", "nounmul", ex),
+ ex:subst("-", "nounsub", ex),
+ ex:subst("/", "noundiv", ex),
+ ex:subst("^", "nounpow", ex),
+ define(UNARY_RECIP a, a^(-1)),
+ ex:ev(ex, UNARY_MINUS=-1),
+ remfunction("nounadd", "nounmul", "noundiv", "nounpow", "nounsub", "nouneq", "UNARY_RECIP"),
+ ex
+)$
+
+/* (4) */
+noun_arith(ex) := block([a],
+ ex:subst("nouneq", "=", ex),
+ ex:subst("nounadd", "+", ex),
+ ex:subst("nounmul", "*", ex),
+ /* Unary minus really communtes with multiplication. */
+ ex:subst(lambda([ex], UNARY_MINUS nounmul ex), "-", ex),
+ /* Turn 1/x into x^(-1), in a special form */
+ ex:subst(lambda([ex1, ex2], ex1 nounmul (UNARY_RECIP ex2)), "/", ex),
+ define(UNARY_RECIP a, a nounpow (-1)),
+ ex:ev(subst("nounpow", "^", ex)),
+ remfunction("UNARY_RECIP"),
+ ev(ex)
+)$
+
+noun_arith_full(ex) := block([a],
+ ex:subst("nouneq", "=", ex),
+ ex:subst("nounadd", "+", ex),
+ ex:subst("nounmul", "*", ex),
+ /* Turn -(7) into integer -7. */
+ ex:transr(ex, mminusInt),
+ /* Unary minus really communtes with multiplication. */
+ ex:subst(lambda([ex], UNARY_MINUS nounmul ex), "-", ex),
+ /* Turn 1/x into x^(-1), in a special form */
+ ex:subst(lambda([ex1, ex2], ex1 nounmul (UNARY_RECIP ex2)), "/", ex),
+ /* Now we have the rules based tests we don't replace UNARY_RECIP. */
+ ex:ev(subst("nounpow", "^", ex)),
+ /* See docs on exp: Instances of 'exp (<x>)' in input are simplified to '%e^<x>'; 'exp' does not appear in simplified expressions. */
+ ex:ev(subst(lambda([ex2],%e nounpow ex2), exp, ex)),
+ ev(ex)
+)$
+
+/* Assumes we are working in the context of noun operators. */
+gather_reduce(ex) := block(
+ ex:subst("=", "nouneq", ex),
+ ex:subst("+", "nounadd", ex),
+ ex:subst("*", "nounmul", ex),
+ ex:subst("-", "nounsub", ex),
+ ex:ev(flatten(ex), simp),
+ ex:subst("nouneq", "=", ex),
+ ex:subst("nounadd", "+", ex),
+ ex:subst("nounmul", "*", ex), --
+ ex:subst("nounsub", "-", ex),
+ ex
+)$
+
+/* This function recursively applies flatten, i.e. this implements nary simplification. */
+flatten_recurse_nouns(ex) := block(
+ if atom(ex) then return(ex),
+ if op(ex)="nounadd" or op(ex)="nounmul" then
+ return(flatten(apply(op(ex), maplist(flatten_recurse_nouns, args(ex))))),
+ if safe_op(ex)="nounset" then
+ return((apply(op(ex), maplist(flatten_recurse_nouns, sort(args(ex)))))),
+ apply(op(ex), maplist(flatten_recurse_nouns, args(ex)))
+)$
+
+sort_nouns(ex) := block([exl],
+ if atom(ex) then return(ex),
+ exl:maplist(sort_nouns, args(ex)),
+ if safe_op(ex)="nouneq" or safe_op(ex)="nounand" or safe_op(ex)="nounor" or safe_op(ex)="nounnot" or safe_op(ex)="nounset" or op(ex)="nounadd" or op(ex)="nounmul" then
+ exl:sort(exl),
+ apply(op(ex), exl)
+)$
+
+/* Rule which takes (a^n)^-1 when n is an integer to a^-n */
+flatten_pow_minus_one(ex):= block(
+ if not(safe_op(ex)="nounpow") then return(ex),
+ if not(second(args(ex))=-1) then return(ex),
+ if safe_op(first(args(ex)))="nounpow" and integerp(second(args(first(args(ex))))) then return("nounpow"(first(args(first(args(ex)))),-second(args(first(args(ex)))))),
+ ex
+)$
+
+/* Recursive rule which takes UNARY_MINUS nounmul n, where n is an integer/float to -n */
+unary_minus_remove(ex):= block([exl],
+ if atom(ex) then return(ex),
+ if not(safe_op(ex)="nounmul") or not(is(first(args(ex))=UNARY_MINUS)) then return(apply(op(ex), maplist(unary_minus_remove, args(ex)))),
+ /* The sort moves any numbers to the front of the list of arguments for *. */
+ exl:sort(rest(args(ex))),
+ if is(length(exl)=1) then return(-first(exl)),
+ exl[1]:-first(exl),
+ apply("nounmul", exl)
+)$
+
+equals_commute_prepare(ex):=block([ex1n],
+ /* We need to strip out any internal simplification. */
+ ex1n:parse_string(string(ex)),
+
+ ex1n:subst(nounset, set, ex1n),
+ ex1n:noun_arith_full(ex1n),
+ ex1n:flatten_recurse_nouns(ex1n),
+ ex1n:sort_nouns(ex1n),
+ return(ex1n)
+)$
+
+/* Returns true iff ex1 and ex2 are equal up to commutativity and associativity. */
+equals_commute_associate(ex1, ex2) := block([oldsimp, ret, ex1n, ex2n],
+ oldsimp:simp,
+ simp:false,
+ ret:false,
+ ex1n:equals_commute_prepare(ex1),
+ ex2n:equals_commute_prepare(ex2),
+
+ if debug then print([ex1n, ex2n]),
+
+ if is(ex1n=ex2n) then ret:true,
+ simp:oldsimp,
+ return(ret)
+)$
+
+/* An answer test in the context of commutative+associative addition and multiplication. */
+ATEqualComAss(sa, sb) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB],
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAss_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAss_STACKERROR_TAns"), ""]),
+
+ /* We need a copy here because lists are passed by reference and the coloring of incorrect entries
+ causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */
+ SAA:remove_stackeq(copy(sa)),
+ SBB:remove_stackeq(copy(sb)),
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(SAA, SBB),
+ if ret[2]=false then
+ (ret[3]:StackAddNote("ATEqualComAss ", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ret[4]]) ),
+ ret:block([simp:true, ret], ATAlgEquiv(SAA, SBB)),
+ if ret[2]=false then
+ (ret[3]:StackAddNote("ATEqualComAss (AlgEquiv-false)", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ""])),
+ /* Now actually apply this test */
+ if equals_commute_associate(SAA, SBB) then
+ (RawMark:true, AnswerNote:"")
+ else
+ (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")),
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+/* Legacy support for direct access to this function. */
+alias(ATEqual_com_ass, ATEqualComAss)$
+
+/* An answer test in the context of commutative+associative addition and multiplication, with identities. */
+ATEqualComAssRules(sa, sb, so) :=
+ block([Validity, RawMark, FeedBack, AnswerNote, ret, SAA, SBB, SOO, debugtest],
+ oldsimp:simp,
+ simp:false,
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ SAA:errcatch(ev(sa, simp, nouns)),
+ if (is(SAA=[STACKERROR]) or is(SAA=[])) then
+ return([false, false, StackAddNote("", "ATEqualComAssRules_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(sb, simp, nouns)),
+ if (is(SBB=[STACKERROR]) or is(SBB=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAssRules_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(so, simp, nouns)),
+ if (is(SOO=[STACKERROR]) or is(SOO=[])) then
+ return([false,false,StackAddNote("", "ATEqualComAssRules_STACKERROR_Opt"), ""]),
+ so:first(SOO),
+ if (not(listp(so)) or emptyp(so)) then
+ return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_List"), StackAddFeedback("", "ATEqualComAssRules_Opt_List")]),
+
+ /* Make sure commutativity and associativity are always in, and tidy up the options. */
+ so:ev(unique(flatten(append(so, ALG_TRANS))), simp),
+ if ev(elementp(testdebug, setify(so)), simp) then block(
+ debugtest:true,
+ so:delete(testdebug, so)
+ ) else debugtest:false,
+
+ if not(all_listp(lambda([ex], ev(elementp(ex, setify(ALL_TRANS)), simp) ), so)) then
+ return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_Wrong"), StackAddFeedback("", "ATEqualComAssRules_Opt_List")]),
+
+ if any_listp(lambda([ex], ev(subsetp(ex, setify(so)), simp) ), INCOMPATIBLE_TRANS) then
+ return([false,false,StackAddNote("", "ATEqualComAssRules_Opt_Incompatible"), StackAddFeedback("", "ATEqualComAssRules_Opt_Incompatible")]),
+
+ SAA:remove_stackeq(copy(sa)),
+ SBB:remove_stackeq(copy(sb)),
+
+ /* We need to check things are of the same type */
+ ret:ATSameTypefun(SAA, SBB),
+ if ret[2]=false then
+ (ret[3]:StackAddNote("ATEqualComAssRules ", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ret[4]]) ),
+ ret:block([simp:true, ret], ATAlgEquiv(SAA, SBB)),
+ /* If they are not algebraically equivalent then we bail. */
+ if ret[2]=false then
+ (ret[3]:StackAddNote("ATEqualComAssRules (AlgEquiv-false)", StackTrimNote(ret[3])), return([false, ret[2], ret[3], ""])),
+
+ /* Put the expressions in basic form. */
+ SAA:equals_commute_prepare(SAA),
+ SBB:equals_commute_prepare(SBB),
+
+ if debug then print(["Transforming", SAA]),
+ SAA:transl(SAA, so),
+ if debug then print(["Transforming", SBB]),
+ SBB:transl(SBB, so),
+
+ AnswerNote:"",
+ if debugtest then AnswerNote:StackAddNote("ATEqualComAssRules: ", string([SAA, SBB])),
+ /* Now actually apply this test */
+ if is(SAA = SBB) then
+ RawMark:true
+ else
+ RawMark:false,
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+/* List of all available rules. */
+ALG_TRANS:[assAdd, assMul, comAdd, comMul]$
+ID_TRANS:[zeroAdd, zeroMul, oneMul, onePow, idPow, zeroPow, zPow, oneDiv]$
+NEG_TRANS:[negNeg, negDiv, negOrd]$
+INT_ARITH:[intAdd, intMul, intPow]$
+DIV_TRANS:[recipMul, divDiv, divCancel]$
+
+ALL_TRANS:append(ALG_TRANS, ID_TRANS, NEG_TRANS, DIV_TRANS, INT_ARITH, [intFac, negDist, sqrtRem])$
+
+/* Set up a hash table of functions and their corresponding predicate. */
+ALL_TRANSP[assAdd] : assAddp$
+ALL_TRANSP[assMul] : assMulp$
+ALL_TRANSP[comAdd] : comAddp$
+ALL_TRANSP[comMul] : comMulp$
+
+ALL_TRANSP[zeroAdd] : zeroAddp$
+ALL_TRANSP[zeroMul] : zeroMulp$
+ALL_TRANSP[oneMul] : oneMulp$
+ALL_TRANSP[onePow] : onePowp$
+ALL_TRANSP[idPow] : idPowp$
+ALL_TRANSP[zeroPow] : zeroPowp$
+ALL_TRANSP[zPow] : zPowp$
+ALL_TRANSP[oneDiv] : oneDivp$
+
+ALL_TRANSP[recipMul] : recipMulp$
+ALL_TRANSP[divDiv] : divDivp$
+ALL_TRANSP[divCancel] : divCancelp$
+ALL_TRANSP[negDist] : negDistp$
+
+ALL_TRANSP[negNeg] : negNegp$
+ALL_TRANSP[negDiv] : negDivp$
+ALL_TRANSP[negOrd] : negOrdp$
+
+ALL_TRANSP[intAdd] : intAddp$
+ALL_TRANSP[intMul] : intMulp$
+ALL_TRANSP[intPow] : intPowp$
+ALL_TRANSP[intFac] : intFacp$
+
+ALL_TRANSP[sqrtRem] : sqrtRemp$
+
+/* These rules are not included in ALL_TRANS. */
+ALL_TRANSP[mminusInt] : mminusIntp$
+
+/* Sets of incompatible rules. */
+INCOMPATIBLE_TRANS : [{intFac, intMul}, {negOrd, negDist}]$
+
+/*******************************************/
+/* Top level transformations using rules */
+/*******************************************/
+
+/* Is the rule applicable at the top level? */
+trans_topp(ex, rl) := ALL_TRANSP[rl](ex)$
+
+/* Transform recursively across an expression. */
+transr(ex, rl) := block(
+ if listp(rl) then error("transr: only apply one rule using transr."),
+ if trans_topp(ex, rl) then block([ex2],
+ ex2:apply(rl, [ex]),
+ if debug then print(["transr: ", rl, ex, ex2]),
+ /* If applying the rule changes the expression then do so. */
+ if ex=ex2 then return(ex) else return(transr(ex2, rl)))
+ else return(if mapatom(ex) then ex else map(lambda([ex2], transr(ex2, rl)), ex))
+)$
+
+/* Apply a list of rules recursively, in order, until the expression stops changing. */
+transl(ex,rll) := block([ex2],
+ if not(listp(rll)) or emptyp(rll) then return(ex),
+ ex2:transl(transr(ex, first(rll)), rest(rll)),
+ if ex=ex2 then return(ex),
+ return(transl(ex2,rll))
+)$
+
+/* This is a special rule used to make sure the single integer (-7) becomes UNARY_MINUS*7.
+ The parser takes -7 as ((MMINUS) 7), but when simplified this becomes the integer -7.
+ We essentially "unsimplify" here to disambiguate.
+ This rule is not included in the main transformation rule base. */
+mminusIntp(ex):= if integerp(ex) and ex<0 then true else false$
+mminusInt(ex) := if mminusIntp(ex) then (UNARY_MINUS nounmul ev(-1*ex, simp)) else ex$
+
+/*******************************************/
+/* Transformation rules. */
+/*******************************************/
+
+/* 0+x -> x. Assumes commutativity. */
+zeroAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and length(sublist(args(ex), lambda([ex2], ex2=0)))>0 then true else false$
+zeroAdd(ex) := block([ex2],
+ if not(zeroAddp(ex)) then return(ex),
+ ex2:sublist(args(ex), lambda([ex2], not(is(ex2=0)))),
+ if equal(length(ex2),1) then return(first(ex2)),
+ return(apply(op(ex), ex2))
+)$
+
+/* zeroMul transform 0*x to 0. Assumes commutativity. */
+zeroMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], ex2=0)))>0 then true else false$
+zeroMul(ex) := block(
+ if zeroMulp(ex) then return(0) else return (ex)
+)$
+
+/* oneMul transform 1*x to x. Assumes commutaivity. */
+oneMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], ex2=1)))>0 then true else false$
+oneMul(ex) := block([ex2],
+ if not(oneMulp(ex)) then return(ex),
+ ex2:sublist(args(ex), lambda([ex2], not(is(ex2=1)))),
+ if equal(length(ex2),1) then return(first(ex2)),
+ return(apply(op(ex), ex2))
+)$
+
+/* 1^x -> 1 */
+onePowp(ex):= if (safe_op(ex)="^" or safe_op(ex)="nounpow") and is(part(ex, 1)=1) then true else false$
+onePow(ex) := if onePowp(ex) then 1 else ex$
+
+/* x^1 -> x */
+idPowp(ex):= if (safe_op(ex)="^" or safe_op(ex)="nounpow") and is(part(ex, 2)=1) then true else false$
+idPow(ex) := if idPowp(ex) then part(ex,1) else ex$
+
+/* 0^x -> 0*/
+zeroPowp(ex):= block(
+ if not(safe_op(ex)="^" or safe_op(ex)="nounpow") or is(part(ex, 2)=0) then return(false),
+ if is(part(ex,1)=0) then true else false
+)$
+zeroPow(ex) := if zeroPowp(ex) then 0 else ex$
+
+/* x^0 -> 1*/
+zPowp(ex):= block(
+ if not(safe_op(ex)="^" or safe_op(ex)="nounpow") or is(part(ex, 1)=0) then return(false),
+ if is(part(ex, 2)=0) then true else false
+)$
+zPow(ex) := if zPowp(ex) then 1 else ex$
+
+/* UNARY_RECIP(1) -> 1 (intended to be used with other rules). */
+oneDivp(ex):= if safe_op(ex)="UNARY_RECIP" and part(ex, 1)=1 then true else false$
+oneDiv(ex) := if oneDivp(ex) then 1 else ex$
+
+/*****************************************/
+
+/* These functions "flatten" sums or products by removing uncessary parentheses
+ i.e. it enforces associativity. */
+/* Note that the predicates only return true if the rule changes the expression */
+assAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and flatten(ex)#ex then true else false$
+assAdd(ex) := if assAddp(ex) then flatten(ex) else ex$
+
+assMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and flatten(ex)#ex then true else false$
+assMul(ex) := if assMulp(ex) then flatten(ex) else ex$
+
+/* Define a predicate to sort elements, UNARY_MINUS at the front, UNARY_RECIP at the end. */
+orderelementaryp(exa,exb) := block(
+ if exa=UNARY_MINUS then return(true),
+ if exb=UNARY_MINUS then return(false),
+ if safe_op(exa)="UNARY_RECIP" and safe_op(exb)="UNARY_RECIP" then return(orderlessp(part(exa, 1), part(exb, 1))),
+ if safe_op(exa)="UNARY_RECIP" then return(false),
+ return(orderlessp(exa,exb))
+)$
+
+/* sort(args(ex), orderelementaryp) does not work :-( */
+elsort(l) := block([l1, l2, la],
+ la:sublist(l, lambda([ex], atom(ex))),
+ l1:sublist(l, lambda([ex], not(atom(ex)) and safe_op(ex)#"UNARY_RECIP")),
+ l2:sublist(l, lambda([ex], not(atom(ex)) and safe_op(ex)="UNARY_RECIP")),
+ append(sort(la, orderelementaryp), sort(l1, orderelementaryp), sort(l2, orderelementaryp))
+)$
+
+/* Sort out the order of elements, i.e. commutativity. */
+/* NOTE: sort(args(ex), orderelementaryp)) should work but does not... */
+comAddp(ex):= if (safe_op(ex)="+" or safe_op(ex)="nounadd") and apply(op(ex), elsort(args(ex)))#ex then true else false$
+comAdd(ex) := if comAddp(ex) then apply(op(ex),elsort(args(ex))) else ex$
+
+comMulp(ex):= if (safe_op(ex)="*" or safe_op(ex)="nounmul") and apply(op(ex), elsort(args(ex)))#ex then true else false$
+comMul(ex) := if comMulp(ex) then apply(op(ex),elsort(args(ex))) else ex$
+
+
+/* Consolidate products of division: a*UNARY_RECIP(b)*UNARY_RECIP(c) -> a*UNARY_RECIP(b*c) */
+recipMulp(ex) := block([ex2],
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false),
+ if length(args(ex))=1 then return(false),
+ ex2:reverse(args(ex)),
+ if safe_op(first(ex2))="UNARY_RECIP" and safe_op(second(ex2))="UNARY_RECIP" then true else false
+)$
+recipMul(ex) := block([ex2],
+ if not(recipMulp(ex)) then return(ex),
+ ex2:reverse(args(ex)),
+ apply(op(ex),append(reverse(rest(rest(ex2))),[UNARY_RECIP(apply(op(ex),[part(second(ex2),1),part(first(ex2),1)]))]))
+)$
+
+/*******************************************/
+/* Double negation -(-(a)). (Assumes unary minus has been replaced by products of UNARY_MINUS */
+negNegp(ex):= block(
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false),
+ if length(sublist(args(ex), lambda([ex2], is(ex2=UNARY_MINUS))))>1 then return(true) else return(false)
+)$
+negNeg(ex) := block([ex0,ex1,ex2],
+ if not(negNegp(ex)) then return(ex),
+ ex1:sublist(args(ex), lambda([ex0], is(ex0=UNARY_MINUS))),
+ ex2:sublist(args(ex), lambda([ex0], not(is(ex0=UNARY_MINUS)))),
+ if is(oddp(length(ex1))) then ex2:append([UNARY_MINUS], ex2),
+ if length(ex2)>1 then apply(op(ex), ex2) else first(ex2)
+)$
+
+/* Double negation UNARY_RECIP(UNARY_MINUS*x)->UNARY_MINUS*UNARY_RECIP(x).
+ (Assumes unary minus has been replaced by products of UNARY_MINUS etc.) */
+negDivp(ex):= block(
+ if not(safe_op(ex)="UNARY_RECIP") then return(false),
+ /* Edge case we have only 1/- left. */
+ if part(ex, 1)=UNARY_MINUS then return(true),
+ if not(safe_op(part(ex, 1))="*" or safe_op(part(ex, 1))="nounmul") then return(false),
+ if is(length(sublist(args(part(ex, 1)), lambda([ex2], is(ex2=UNARY_MINUS))))>0) then return(true) else return(false)
+)$
+negDiv(ex) := block([ex0, ex1, ex2],
+ if not(negDivp(ex)) then return(ex),
+ if part(ex, 1)=UNARY_MINUS then return(UNARY_MINUS),
+ ex1:sublist(args(part(ex, 1)), lambda([ex0], is(ex0=UNARY_MINUS))),
+ /* This should not happen, but! */
+ if emptyp(ex1) then return(ex),
+ ex2:sublist(args(part(ex, 1)), lambda([ex0], not(is(ex0=UNARY_MINUS)))),
+ if length(ex1)>1 then ex1:apply(op(part(ex, 1)), ex1) else ex1:UNARY_MINUS,
+ if length(ex2)>1 then ex2:apply(op(part(ex, 1)), ex2) else ex2:first(ex2),
+ return (ex1 nounmul UNARY_RECIP(ex2))
+)$
+
+negOrdp(ex) := block([ex2,ex3],
+ if not(safe_op(ex)="+" or safe_op(ex)="nounadd") then return(false),
+ /* Order the terms in the sum, strip off any UNARY_MINUS, and compare the leading term. */
+ ex2:elsort(args(ex)),
+ ex3:map(lambda([ex0], if not(safe_op(ex0)="*" or safe_op(ex0)="nounmul") then ex0
+ else block([a1], a1:sublist(args(ex0), lambda([ex1], not(ex1=UNARY_MINUS))), if length(a1)=1 then first(a1) else apply(op(ex0), a1) )), ex2),
+ ex3:elsort(ex3),
+ not(is(first(ex2)=first(ex3)))
+)$
+negOrd(ex) := block([ex0],
+ if not(negOrdp(ex)) then return(ex),
+ /* We use commutativity of multiplication to pull UNARY_MINUS to the front. */
+ ex0:map(comMul, args(ex)),
+ ex0:map(lambda([ex1], if (atom(ex1) or not(safe_op(ex1)="*" or safe_op(ex1)="nounmul")) then (UNARY_MINUS nounmul ex1)
+ else if not(first(args(ex1))=UNARY_MINUS) then (UNARY_MINUS nounmul ex1)
+ else if length(rest(args(ex1)))=1 then first(rest(args(ex1))) else apply(op(ex1), rest(args(ex1)))), ex0),
+ return(UNARY_MINUS nounmul (apply(op(ex), ex0)))
+)$
+
+/* Distribute negation over addition. (Assumes unary minus has been replaced by products of UNARY_MINUS */
+negDistp(ex):= block(
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false),
+ if length(sublist(args(ex), lambda([ex2], is(ex2=UNARY_MINUS))))=0 then return(false),
+ if length(sublist(args(ex), lambda([ex2], is(safe_op(ex2)="+" or safe_op(ex2)="nounadd"))))=0 then return(false),
+ return(true)
+)$
+negDist(ex) := block([ex0,ex1,ex2,ex3],
+ if not(negDistp(ex)) then return(ex),
+ ex1:sublist(args(ex), lambda([ex0], is(ex0=UNARY_MINUS))),
+ ex2:sublist(args(ex), lambda([ex0], is(safe_op(ex0)="+" or safe_op(ex0)="nounadd"))),
+ ex3:sublist(args(ex), lambda([ex0], not(is(ex0=UNARY_MINUS)) and not(is(safe_op(ex0)="+" or safe_op(ex0)="nounadd")))),
+ ex0:apply(op(first(ex2)),map(lambda([ex4],apply(op(ex),[UNARY_MINUS,ex4])),args(first(ex2)))),
+ apply(op(ex),append(rest(ex1),rest(ex2),[ex0],ex3))
+)$
+
+/* a/(b/c)-> a*(c/b) */
+/* Helper which establishes an expression is "UNARY_RECIP" or a product which contains at least one "UNARY_RECIP" */
+divDivProdp(ex):= block(
+ if safe_op(ex)="UNARY_RECIP" then return(true),
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false),
+ return(any_listp(lambda([ex2], is(safe_op(ex2)="UNARY_RECIP")), args(ex)))
+)$
+divDivp(ex):= block([ex2],
+ if safe_op(ex)="UNARY_RECIP" then return(divDivProdp(part(ex,1))),
+ if not(safe_op(ex)="*" or safe_op(ex)="nunmul") then return(false),
+ ex2:sublist(args(ex),lambda([ex3], safe_op(ex3)="UNARY_RECIP")),
+ if emptyp(ex2) then return(false),
+ ex2:map(first,ex2),
+ return(any_listp(divDivProdp, ex2))
+)$
+
+/* Helper function.
+ TP is the top product: things which don't get changed (retain original operator).
+ TR is the argument of the first occurance of UNARY_RECIP.
+ Returns [TP,TR]: things which don't change and thing which do.
+ This is complex because we have uncertain numbersof arguments in an nary nounmul, and might be left with none!
+*/
+divDivProd(ex):= block([TP,TR],
+ TP:[],
+ if safe_op(ex)="UNARY_RECIP" then return([TP,part(ex,1)]),
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return([ex],[]),
+ TR:first(sublist(args(ex),lambda([ex3], safe_op(ex3)="UNARY_RECIP"))),
+ if emptyp(TR) then return(ex,[]),
+ TP:removeonce(TR, args(ex)),
+ if length(TP)=1 then TP:first(TP) else TP:apply(op(ex), TP) ,
+ return([TP,part(TR,1)])
+)$
+divDiv(ex) := block([ex2,ex3,exo,exl],
+ if not(divDivp(ex)) then return(ex),
+ /* Store the operator for later. */
+ exo:"nounmul",
+ if safe_op(ex)="*" then exo:"*",
+ /* Split expression into bits. */
+ ex2:divDivProd(ex),
+ /* This should not really occur because of the predicate divDivP.... */
+ if emptyp(second(ex2)) then return(ex),
+ ex3:divDivProd(second(ex2)),
+ /* Reassemble, emoving any empty lists (which are nulls here). */
+ exl:sublist([first(ex2),second(ex3),if not(emptyp(first(ex3))) then UNARY_RECIP(first(ex3)) else []], lambda([ex4], not(emptyp(ex4)))),
+ if length(exl)=1 then first(exl) else flatten(apply(exo,exl))
+)$
+
+/* We have a product containing a division. */
+/* This rule implicitly assumes recipMul, i.e. it takes everything in the product. */
+/* This rule will also cancel NEG tokens as needed. */
+divCancelp(ex) := if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(sublist(args(ex), lambda([ex2], safe_op(ex2)="UNARY_RECIP")))>0 then true else false$
+
+divCancel(ex) := block([ex1, ex2, ex3],
+ if not(divCancelp(ex)) then return(ex),
+ ex1:sublist(args(ex), lambda([l1], not(safe_op(l1)="UNARY_RECIP"))),
+ ex2:flatten(map(args, sublist(args(ex), lambda([l1], safe_op(l1)="UNARY_RECIP")))),
+ ex2:flatten(map(lambda([ex3], if (safe_op(ex3)="*" or safe_op(ex3)="nounmul") then args(ex3) else ex3), ex2)),
+ /* At this point ex1 is a list of factors in the numerator, and ex2 is a list of factors in the denominator. */
+ ex3:list_cancel([ex1,ex2]),
+ ex1:first(ex3),
+ ex2:second(ex3),
+ if emptyp(ex1) and emptyp(ex2) then return(1),
+ if length(ex2)=1 then ex1:append(ex1,[UNARY_RECIP(first(ex2))]),
+ if length(ex2)>1 then ex1:append(ex1,[UNARY_RECIP(apply("nounmul", ex2))]),
+ if length(ex1)=1 then return(first(ex1)),
+ return(apply("nounmul", ex1))
+)$
+
+/**********************************************************/
+/* Dealing with powers. */
+
+/* Remove the square root function. */
+sqrtRemp(ex):= is(safe_op(ex)="sqrt")$
+sqrtRem(ex):=first(ex) nounpow (1 nounmul UNARY_RECIP(2))$
+
+
+/**********************************************************/
+/* We either have an integer, or "UNARY_MINUS * integer". */
+noun_simp_integerp(ex) := if atom(ex) then integerp(ex) else
+ if (safe_op(ex)="*" or safe_op(ex)="nounmul") and length(args(ex))=2 and part(ex, 1)=UNARY_MINUS and atom(part(ex, 2)) and integerp(part(ex, 2)) then true else false$
+notnoun_simp_integerp(ex):=not(noun_simp_integerp(ex))$
+
+/* Evaluate integer arithmetic */
+intAddp(ex):= block(
+ if not(safe_op(ex)="+" or safe_op(ex)="nounadd") then return(false),
+ if length(sublist(args(ex), noun_simp_integerp))>1 then return(true) else return(false)
+)$
+intAdd(ex) := block([a1, a2],
+ if intAddp(ex)=false then return(ex),
+ a1:sublist(args(ex), noun_simp_integerp),
+ a1:map(verb_arith, a1),
+ a1:mminusInt(ev(apply("+", a1), simp)),
+ a2:sublist(args(ex), notnoun_simp_integerp),
+ if length(a2)=0 then a1
+ else apply(op(ex),append([a1], a2))
+)$
+
+intMulp(ex):= block(
+ if not(safe_op(ex)="*" or safe_op(ex)="nounmul") then return(false),
+ if length(sublist(args(ex), integerp))>1 then return(true) else return(false)
+)$
+intMul(ex) := block([a1, a2],
+ if intMulp(ex)=false then return(ex),
+ a1:sublist(args(ex), noun_simp_integerp),
+ a1:map(verb_arith, a1),
+ a1:mminusInt(ev(apply("*", a1), simp)),
+ a2:sublist(args(ex), notnoun_simp_integerp),
+ if length(a2)=0 then a1
+ else apply(op(ex), append([a1], a2))
+)$
+
+intPowp(ex):= block(
+ if not(safe_op(ex)="^" or safe_op(ex)="nounpow") then return(false),
+ if integerp(part((ex),1)) and part((ex),1)#0 and integerp(part((ex),2)) and part((ex),2)#0 then return(true) else return(false)
+)$
+intPow(ex) := block([a1, a2],
+ if intPowp(ex)=false then return(ex),
+ ev(ex, simp)
+)$
+
+intFacp(ex):= integerp(ex)$
+intFac(ex) := block([a1],
+ if intFacp(ex)=false then return(ex),
+ noun_arith(factor(ex))
+)$
diff --git a/stack/2023102700/maxima/numericaltest.mac b/stack/2023102700/maxima/numericaltest.mac
new file mode 100644
index 0000000000000000000000000000000000000000..335b9937955303af74442477ba3f2866b5f628a2
--- /dev/null
+++ b/stack/2023102700/maxima/numericaltest.mac
@@ -0,0 +1,464 @@
+/* ********************************** */
+/* Numerical operations */
+/* ********************************** */
+
+/* Support for stateful. */
+alias(ATNumSigFigs_CASSigFigsWrapper, ATNumSigFigs)$
+alias(ATSigFigsStrict_CASSigFigsWrapper, ATSigFigsStrict)$
+alias(ATNumDecPlaces_CASDecPlacesWrapper, ATNumDecPlaces)$
+
+ATNumAbsolute(SA, SB, SO) := ATNumerical(SA, SB, SO, "ABSOLUTE")$
+ATNumRelative(SA, SB, SO) := ATNumerical(SA, SB, SO, "RELATIVE")$
+
+ATNumerical(SA, SB, SO, numtype) := block([simp:true, RawMark, FeedBack, AnswerNote, ret, SAN, tol],
+ Validity:true, RawMark:false,
+ FeedBack:StackAddFeedback("", "ATNumerical_FAILED"),
+ AnswerNote:StackAddNote("", "ATNumerical_FAILED"),
+ /* Turn on simplification and error catch */
+ SA:errcatch(ev(float(SA), simp, nouns)),
+ if is(SA = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_SAns")),
+ SA:SA[1],
+ SAN:copy(SA), /* Need this for when we have lists etc. */
+ SB:errcatch(ev(float(remove_numerical_inert(SB)), simp, nouns, rat)),
+ if is(SB = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_TAns")),
+ SB:SB[1],
+ SO:errcatch(ev(float(SO), simp, nouns, rat)),
+ if is(SO = [STACKERROR]) then return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_Opt")),
+ tol:SO[1],
+ if not(numberp(tol)) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_STACKERROR_tol"))),
+
+ if not(elementp(numtype, {"ABSOLUTE", "RELATIVE"})) then (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATNumerical_testname_invalid"))),
+
+ /* Are we dealing with lists? */
+ if listp(SB) then
+ if listp(SAN)#true then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_list"))
+ else
+ return(ATNumerical_list(SA, SB, numtype, tol)),
+
+ /* Are we dealing with sets? */
+ if safe_setp(SB) then
+ if safe_setp(SAN)=false then
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_set"))
+ else
+ return(ATNumerical_set(SA, SB, numtype, tol)),
+
+ /* Are we dealing with numbers? */
+ if (debug) then print ([SA,SB,tol]),
+ if numberp(SAN) then
+ if numberp(SB) then
+ if numtype = "ABSOLUTE" then
+ return([true, numabsolutep(SA, SB, tol), "", ""])
+ else
+ return([true, numrelativep(SA, SB, tol), "", ""])
+ else
+ return(StackBasicReturn(false, false, "ATNumerical_SB_not_number"))
+ else
+ return(StackBasicReturn(false, false, "ATNumerical_SA_not_number")),
+
+ ret:[Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+)$
+
+/* We have to define our own working precision. */
+STACK_NUM_TOL:10E-10$
+numabsolutep(sa,ta,tol) := if ev(abs(float(sa-ta)), simp) < ev(abs(tol)+STACK_NUM_TOL, simp) then true else false;
+/* The equality sign below is to accommodate the edge case numrelativep(0.0,0.0,0.0?). Needed for units tests with things like 0m/s. */
+numrelativep(sa,ta,tol) := if ev(abs(float(sa-ta)), simp) <= ev(abs(ta*tol*(1+STACK_NUM_TOL)), simp) then true else false;
+
+ATNumerical_list(SA, SB, numtype, tol) := block([SAl, SBl, cl, res, fb:"", an:""],
+ SAl:length(SA),
+ SBl:length(SB),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("","ATNumerical_wronglen"), StackAddFeedback("", "ATList_wronglen", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]),
+
+ if numtype = "ABSOLUTE" then
+ cl:zip_with(lambda([ex1,ex2], numabsolutep(ex1, ex2, tol)), SA, SB)
+ else
+ cl:zip_with(lambda([ex1,ex2], numrelativep(ex1, ex2, tol)), SA, SB),
+
+ res:apply("and", cl),
+ if not(res) then block([we],
+ fb:zip_with(lambda([ex1,ex2],if ex1 then ex2 else texcolor("red", ex2)), cl, SA),
+ we:maplist(second, sublist(zip_with("[", cl, SA), lambda([ex], not(first(ex))))),
+ an:StackAddNote("", concat("ATNumerical_wrongentries SA/TA=", string(we))),
+ fb:StackAddFeedback("", "ATList_wrongentries", stack_disp(fb, "d"))
+ ),
+
+ return([true, res, an, fb])
+)$
+
+ATNumerical_set(SA, SB, numtype, tol) := block([SAl, SBl, cl, res, fbl, fb:"", an:""],
+ SAl:length(SA),
+ SBl:length(SB),
+ if (SAl#SBl) then
+ return([true, false, StackAddNote("","ATNumerical_wronglen"), StackAddFeedback("", "ATSet_wrongsz", stack_disp(SBl, "i"), stack_disp(SAl, "i"))]),
+
+ /* Why on earth has listify stopped working...?! */
+ SA:sort(float(args(SA))),
+ SB:sort(float(args(SB))),
+ fbl:num_compare_helper(SA, SB, [], [], tol, numtype),
+ if emptyp(first(fbl)) and emptyp(second(fbl)) then res:true else res:false,
+
+ if not(res) then block(
+ fb:setify(reverse(maplist(lambda([ex], texcolor("red", ex)), second(fbl)))),
+ fb:StackAddFeedback("", "ATList_wrongentries", stack_disp(fb, "d")),
+ an:StackAddNote("", concat("ATNumerical_wrongentries: TA/SA=", string(reverse(first(fbl))), ", SA/TA=", string(reverse(second(fbl)))))
+ ),
+
+ return([true, res, an, fb])
+)$
+
+/***************************************************
+Need a function which identifies which elements of the student's set, fall within "tolerance-balls" of elements of the teacher's set.
+
+Takes various arguments
+(1) student's list
+(2) teacher's list
+(3) numbers in the student's list, not within appropriate tolerance of any in the teacher's list
+(4) numbers in the teacher's list, which do not occur (approximated) in the student's
+(5) tolerance - whether this is absolute or relative to the teacher's answer needs to be sorted out internally to the function.
+(6) type - either "ABSOLUTE" or "RELATIVE"
+
+Returns all of the above + a feedback list.
+
+All arguments 1-2 are ordered lists of floats, smallest to largest.
+
+Want sa to lie between
+(ta-tol,ta+tol) or (ta-ta*tol,ta+ta*tol) depending on "ABSOLUTE" or "RELATIVE" (respectively)
+****************************************************/
+num_compare_helper(sal, tal, missing, excessive, tol, type) := block([sa, ta, f1, f2],
+ /* If we've run out of answers */
+ if emptyp(sal) and emptyp(tal) then return([missing, excessive]),
+ if emptyp(sal) then return([append(tal, missing), excessive]),
+ if emptyp(tal) then return([missing, append(sal, excessive)]),
+ /* Otherwise, we take the first element of the list and calculate */
+ /* if sa<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, SR) := block([simp, Validity, RawMark, FeedBack, AnswerNote, ret, ol, nsf, asf, c0, c1, c2, SAA, SBB, SOO],
+ simp:false,
+ Validity:true, RawMark:true, FeedBack:"", AnswerNote:"",
+
+ /* The return value */
+ 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"), ""]),
+ SRR:errcatch(ev(SR, simp, nouns)),
+ if (is(SRR = [STACKERROR]) or is(SRR = [])) then return([false, false, StackAddNote("","ATNumSigFigs_STACKERROR_Raw"), ""]),
+
+ /* 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.
+ */
+ 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")])),
+
+
+ requiredsigfigs: 3,
+ requiredaccuracy: -1,
+ allowextra: false,
+ if listp(ol) then (
+ requiredsigfigs: ol[1],
+ requiredaccuracy: ol[2]
+ ) else (
+ requiredsigfigs: ol,
+ requiredaccuracy: ol
+ ),
+
+ 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. */
+ if not(stringp(SR)) then SR:string(SR),
+ digits:sig_figs_from_str(SR),
+
+ 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 return([Validity, RawMark, AnswerNote, FeedBack]),
+
+ /* Remove ephemeral forms from teacher's answers. */
+ SB:remove_numerical_inert(SB),
+ /* SA should be only a number. */
+ if (not(ATNumSigFigs_numberp(SA))) then
+ return([false, false, StackAddNote("", "ATNumSigFigs_NotDecimal"), StackAddFeedback("", "ATNumSigFigs_NotDecimal")]),
+ /* Don't simplify until now. */
+ if is(_EC(errcatch(SA:ev(SA, simp, nouns)), "") = false) then return([false, false, StackAddNote("", "ATNumSigFigs_Error simplifying SAns"),""]),
+ /* In the case of teacher's options [n,0] we ignore the question of numerical accuracy. */
+ if ev(is(asf = 0), simp) then
+ return([Validity, RawMark, AnswerNote, FeedBack]),
+ /* Check answers have the same algebraic sign. */
+ if ev(not(is(sign(SA)=sign(SB))), simp) then block(
+ RawMark:false,
+ FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_WrongSign"),
+ AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_WrongSign")
+ ),
+ SA:ev(abs(SA), simp),
+ SB:ev(abs(SB), simp),
+ /* Round the teacher's answer to the correct number of significant figures prior to comparison. */
+ SB:significantfigures(SB, nsf),
+ /* Find a power c0 which puts SB*10^c0 between 0 & 1 */
+ if not(is(SB=0) or is(SB=0.0)) then
+ c0:ev(-floor(log(abs(float(rat(SB))))/log(10)+1), simp)
+ else
+ c0:0.0,
+ /* In the case where we have an option [m,-1] we don't need the numerical accuracy to match for more than m significant figures. */
+ if ev(is(asf<0), simp) then block(
+ SA:significantfigures(SA, nsf),
+ asf:nsf
+ ),
+ ev(c2:float(abs(abs(rat(SA)*10^(c0+floor(asf)))-abs(rat(SB)*10^(c0+floor(asf))))), simp),
+ if (debug) then print([SA,SB,c0,asf,c2]),
+ if not(ev(is(c2<(0.5)), simp)) then block(
+ Validity:true,
+ RawMark:false,
+ if ev(is(c2<5), simp) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATNumSigFigs_Inaccurate"),
+ AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_Inaccurate")
+ ) else block(
+ AnswerNote:StackAddNote(AnswerNote, "ATNumSigFigs_VeryInaccurate")
+ )
+ ),
+ ret: [Validity, RawMark, AnswerNote, FeedBack],
+ return(ret)
+)$
+
+ATSigFigsStrict(SA, SB, requiredsigfigs, rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote],
+ /* The return value */
+ Validity: true,
+ RawMark: false,
+ FeedBack: "",
+ AnswerNote: "",
+
+ /* What if the options do not make sense? */
+ /* Note that the options may now be dynamic and evaluated in CAS. */
+ if requiredsigfigs <= 0 or not integerp(requiredsigfigs) then (
+ return([false, false, "STACKERROR_OPTION.", ""])
+ ),
+
+ /* Find the number of digits. */
+ digits: sig_figs_from_str(rawsans),
+
+ if requiredsigfigs = stackmap_get(digits, "lowerbound") then (
+ RawMark: true
+ ) else if stackmap_get(digits, "lowerbound") <= requiredsigfigs and requiredsigfigs <= stackmap_get(digits, "upperbound") then (
+ AnswerNote: StackAddNote(AnswerNote, "ATSigFigsStrict_WithinRange")
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+ATNumSigFigs_numberp(ex) := block([ts],
+ ts:ex,
+ if safe_op(ts)="-" then ts:first(args(ts)),
+ if floatnump(ts) or integerp(ts) or scientific_notationp(ts) then return(true),
+ return(false)
+ )$
+
+ATNumDecPlaces(sans,tans,options,rawsans) := block([digits,Validity,RawMark,FeedBack,AnswerNote,required,val],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ SAA:errcatch(ev(sans, simp, nouns)),
+ if (is(SAA = [STACKERROR]) or is(SAA = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(tans, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(options, simp, nouns)),
+ if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_Opt"), ""]),
+ SRR:errcatch(ev(rawans, simp, nouns)),
+ if (is(SRR = [STACKERROR]) or is(SRR = [])) then return([false, false, StackAddNote("","ATNumDecPlaces_STACKERROR_Raw"), ""]),
+
+ /* First check if the students answer is a float. */
+ if not ev(floatnump(sans),simp) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_SA_Not_num"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Float"),
+ RawMark: false,
+ Validity: false
+ ),
+
+ /* Now many digits needed? */
+ required: ev(options,numer,simp),
+
+ if not integerp(required) or is(required<1) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_OptNotInt"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_OptNotInt", stack_disp(options, "i")),
+ RawMark: false,
+ Validity: false
+ ),
+
+ if Validity then (
+ if not(stringp(rawsans)) then rawsans:string(rawsans),
+ /* Find the number of digits. */
+ digits: sig_figs_from_str(rawsans),
+
+ /* Does it match the number of digits? */
+ if is(stackmap_get(digits, "decimalplaces")=required) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Correct")
+ ) else (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Wrong_DPs"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Wrong_DPs"),
+ RawMark: false
+ ),
+
+ /* Then the actual value. Simply round to required and
+ then check the difference. */
+ val: ev(float(round(sans*10^required)),simp),
+ val: ev(val - ev(float(round(remove_displaydp(tans)*10^required)),simp),simp),
+ val: ev(abs(val),simp),
+ if is(val < 0.1) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Equiv")
+ ) else (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlaces_Not_equiv"),
+ RawMark: false
+ )
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
+
+
+ATNumDecPlacesWrong(sans,tans,options) := block([Validity,RawMark,FeedBack,AnswerNote,_sans,_tans,required],
+ Validity: true,
+ RawMark: true,
+ FeedBack: "",
+ AnswerNote: "",
+
+ SAA:errcatch(ev(sans, simp, nouns)),
+ if (is(SAA = [STACKERROR]) or is(SAA = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_SAns"), ""]),
+ SBB:errcatch(ev(tans, simp, nouns)),
+ if (is(SBB = [STACKERROR]) or is(SBB = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_TAns"), ""]),
+ SOO:errcatch(ev(options, simp, nouns)),
+ if (is(SOO = [STACKERROR]) or is(SOO = [])) then return([false, false, StackAddNote("","ATNumDecPlacesWrong_STACKERROR_Opt"), ""]),
+
+ /* First check if the students answer is a number. */
+ if not ev(numberp(sans),simp) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_SA_Not_num"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlaces_Float"),
+ RawMark: false,
+ Validity: false
+ ),
+ /* Also teachers answer. */
+ if not ev(numberp(remove_numerical_inert(tans)), simp) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Tans_Not_Num"),
+ RawMark: false,
+ Validity: false
+ ),
+
+ /* Now many digits needs to match? */
+ required: ev(options,numer,simp),
+
+ if not integerp(required) or is(required<1) then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_OptNotInt"),
+ FeedBack: StackAddFeedback(FeedBack, "ATNumDecPlacesWrong_OptNotInt", stack_disp(options, "i")),
+ RawMark: false,
+ Validity: false
+ ),
+
+ if Validity then (
+ /* Shift the values to same range and cut to the required
+ match length. */
+ _sans:ev(sans,numer),
+ _tans:ev(remove_numerical_inert(tans),numer),
+
+ /* Special case, if either one is 0. */
+ if is(_sans=0) or is(_sans=0.0) or is(_tans=0) or is(_tans=0.0) then (
+ RawMark: ev(is(_sans-_tans < 10^-required),numer,simp),
+ if RawMark then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Correct")
+ ) else (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Wrong")
+ ),
+ return([Validity, RawMark, AnswerNote, FeedBack])
+ ),
+
+ /* Now that log(0) has been handled shift the numbers */
+ _sans:ev(_sans*10^floor(-log(abs(_sans))/log(10)+required),numer,simp),
+ _tans:ev(_tans*10^floor(-log(abs(_tans))/log(10)+required),numer,simp),
+
+ /* Truncate extras. */
+ _sans:floor(_sans),
+ _tans:floor(_tans),
+
+ RawMark: ev(is(abs(_sans-_tans) < 0.1),numer,simp),
+ if RawMark then (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Correct")
+ ) else (
+ AnswerNote: StackAddNote(AnswerNote, "ATNumDecPlacesWrong_Wrong")
+ )
+ ),
+
+ return([Validity, RawMark, AnswerNote, FeedBack])
+)$
\ No newline at end of file
diff --git a/stack/2017121800/maxima/rtest_assessment_simpboth.mac b/stack/2023102700/maxima/rtest_assessment_simpboth.mac
similarity index 91%
rename from stack/2017121800/maxima/rtest_assessment_simpboth.mac
rename to stack/2023102700/maxima/rtest_assessment_simpboth.mac
index bc02f607f7cb9219dbadde904a5e70c875460a14..ff1f51b40d8f0f2fda30958c12f7c78121fe1a3e 100644
--- a/stack/2017121800/maxima/rtest_assessment_simpboth.mac
+++ b/stack/2023102700/maxima/rtest_assessment_simpboth.mac
@@ -125,13 +125,13 @@ irred_Q(1-x,x);
irred_Q(2-3*x,x);
[true,"",false]$
irred_Q(2*x-2,x);
-[false,"stack_trans('irred_Q_commonint'); ",true]$
+[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",true]$
irred_Q(t+t*x,x);
-[false,"",false]$
+[false,"stack_trans('ATFacForm_notpoly'); !NEWLINE!"]$
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]$
+[true,"stack_trans('irred_Q_optional_fac' , !quot!\\(4\\,x^2\\)!quot! ); !NEWLINE!",false]$
irred_Q(x^2-4,x);
[false,"",false]$
irred_Q(x^2-2,x);
@@ -151,22 +151,24 @@ irred_Q(1+x^2+x^5,x);
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]$
+[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",false]$
irred_Q(9-3*x+3*x^5,x);
-[false,"stack_trans('irred_Q_commonint'); ",true]$
+[false,"stack_trans('irred_Q_commonint'); !NEWLINE!",true]$
-irred_power_Qp(2,x);
+PartFrac_term_p(2,x);
true$
-irred_power_Qp((x-1)^2,x);
+PartFrac_term_p(1/(x-1)^2,x);
true$
-irred_power_Qp((3*x-6)^4,x);
+PartFrac_term_p(1/(3*x-6)^4,x);
true$
-irred_power_Qp(x^2-1,x);
+PartFrac_term_p(1/(x^2-1),x);
false$
-irred_power_Qp(3*x-6*x^3+3*x^6,x);
+PartFrac_term_p(1/(3*x-6*x^3+3*x^6),x);
false$
-irred_power_Qp(9-3*x+3*x^5,x);
+PartFrac_term_p(1/(9-3*x+3*x^5),x);
true$
+PartFrac_term_p(x/(x-1),x);
+false$
continuousp(x^2,x,1);
true$
@@ -312,7 +314,7 @@ stack_disp(a+1, "i");
stack_disp(1, "i");
"\\(1\\)"$
stack_disp(false, "i");
-"\\(\\mathbf{false}\\)"$
+"\\(\\mathbf{!BOOLFALSE!}\\)"$
stack_disp(ab0, "i");
"\\({{\\it ab}}_{0}\\)"$
stack_disp(epsilon0345, "i");
@@ -371,3 +373,5 @@ factorlist(-x^2-5*x+6);
factorlist(x^3-1);
[x-1,x^2+x+1]$
+cartesian_product({1, 2}, {3, 4});
+{[1, 3], [1, 4], [2, 3], [2, 4]}$
diff --git a/stack/2017121800/maxima/rtest_assessment_simpfalse.mac b/stack/2023102700/maxima/rtest_assessment_simpfalse.mac
similarity index 98%
rename from stack/2017121800/maxima/rtest_assessment_simpfalse.mac
rename to stack/2023102700/maxima/rtest_assessment_simpfalse.mac
index e4228b9e71eb7c68bb17ca3e422e64f505c7d9d0..e3728ac2bcdb852bbff43512f967757ad8b6a2b2 100644
--- a/stack/2017121800/maxima/rtest_assessment_simpfalse.mac
+++ b/stack/2023102700/maxima/rtest_assessment_simpfalse.mac
@@ -105,9 +105,9 @@ 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)$
+3*(x^-1+1^-1)$
buggy_pow( 3*(x+1)^-2 );
-3*(1/x^2+1/1^2)$
+3*(x^-2+1^-2)$
buggy_pow(sin(sqrt(a+b)));
sin(sqrt(a)+sqrt(b))$
diff --git a/stack/2017121800/maxima/rtest_assessment_simptrue.mac b/stack/2023102700/maxima/rtest_assessment_simptrue.mac
similarity index 100%
rename from stack/2017121800/maxima/rtest_assessment_simptrue.mac
rename to stack/2023102700/maxima/rtest_assessment_simptrue.mac
diff --git a/stack/2017121800/maxima/rtest_experimental.mac b/stack/2023102700/maxima/rtest_experimental.mac
similarity index 100%
rename from stack/2017121800/maxima/rtest_experimental.mac
rename to stack/2023102700/maxima/rtest_experimental.mac
diff --git a/stack/2017121800/maxima/rtest_inequalities.mac b/stack/2023102700/maxima/rtest_inequalities.mac
similarity index 100%
rename from stack/2017121800/maxima/rtest_inequalities.mac
rename to stack/2023102700/maxima/rtest_inequalities.mac
diff --git a/stack/2023102700/maxima/rtest_intervals.mac b/stack/2023102700/maxima/rtest_intervals.mac
new file mode 100644
index 0000000000000000000000000000000000000000..bea1b61f6b460d90c7213df17a5f2c4d5d49d7c9
--- /dev/null
+++ b/stack/2023102700/maxima/rtest_intervals.mac
@@ -0,0 +1,161 @@
+trivialintervalp(oo(1,1));
+true$
+
+trivialintervalp(oo(1,2));
+false$
+
+intervalp(oc(a,b));
+true$
+
+inintervalp(3,oo(-1,4));
+true$
+
+interval_subsetp(oo(1,2), %union(oo(1,2),cc(4,5)));
+true$
+
+interval_subsetp(%union(oo(1,2),cc(4,5)),%union(oo(1,2),cc(4,5),oc(-5,-2)));
+true$
+
+interval_containsp(oo(1,2), oo(1,2));
+true$
+
+interval_containsp(oo(1,2), %union(oo(-1,2),cc(1,2)));
+false$
+
+interval_containsp(oo(1,2), %union(oo(-1,2),oo(1,2)));
+true$
+
+realsetp({1,2});
+true$
+
+realsetp({1,a});
+false$
+
+interval_count_components({});
+0$
+
+interval_count_components(oo(-1,1));
+1$
+
+interval_count_components(%union(oo(-1,1),oo(3,5)));
+2$
+
+interval_count_components(%union(oo(-1,1),oo(3,5),%union({1,2,3},cc(-6,6))));
+6$
+
+natural_domain(x+y);
+unknown$
+
+natural_domain(1);
+all$
+
+natural_domain(x);
+all$
+
+natural_domain(1+x);
+all$
+
+natural_domain(1+abs(x));
+all$
+
+natural_domain(1/x);
+realset(x,%union(oo(0,inf),oo(-inf,0)))$
+
+natural_domain(1/x^2);
+realset(x,%union(oo(0,inf),oo(-inf,0)))$
+
+natural_domain(1/(1+x^2));
+all$
+
+natural_domain(1+1/x);
+realset(x,%union(oo(0,inf),oo(-inf,0)))$
+
+natural_domain(1+x^2+1/(x-1));
+realset(x,%union(oo(1,inf),oo(-inf,1)))$
+
+natural_domain(1+1/x^2+1/(x-1));
+realset(x,%union(oo(0,1),oo(1,inf),oo(-inf,0)))$
+
+natural_domain(1+1/x^2+1/(x+1));
+realset(x,%union(oo(-1,0),oo(0,inf),oo(-inf,-1)))$
+
+natural_domain(5*x/(2*x+1)-3/(x+1) = 1);
+realset(x,%union(oo(-1,-1/2),oo(-1/2,inf),oo(-inf,-1)))$
+
+natural_domain(1+log(x^2-4));
+realset(x,%union(oo(2,inf),oo(-inf,-2)))$
+
+natural_domain(ln(x)+ln(-x));
+none$
+
+natural_domain(ln(-x^2));
+none$
+
+natural_domain(ln(1-x^2));
+realset(x,oo(-1,1))$
+
+natural_domain(sqrt(3*x+4) = sqrt(x+2)+2);
+realset(x,co(-4/3,inf))$
+
+natural_domain(sqrt(x-7)/(64-x^2));
+realset(x,%union(co(7,8),oo(8,inf)))$
+
+natural_domain((9*sqrt(x))/2+2/x^2);
+realset(x,oo(0,inf))$
+
+natural_domain(log(x)/(x-1));
+realset(x,%union(oo(0,1),oo(1,inf)))$
+
+single_variable_solver_real(x^2-4>0);
+realset(x,%union(oo(2,inf),oo(-inf,-2)))$
+
+single_variable_solver_real(2*x/abs(x-1)<1);
+(1-(2*x)/(x-1) > 0) %or ((2*x)/(x-1)+1 > 0)$
+
+single_variable_solver_real(x>1 or x<2);
+all$
+
+interval_disjointp(oo(2,inf),oo(-inf,1));
+true$
+
+interval_sort(%union(oo(2,3),oo(-2,1)));
+[oo(-2,1),oo(2,3)]$
+
+interval_tidy([%union(oo(1,4),cc(5,6)),oo(-100,10)]);
+oo(-100,10)$
+
+interval_complement(oo(1,2));
+%union(oc(-inf,1),co(2,inf))$
+
+interval_complement(X);
+oo(-inf,inf)$
+
+interval_complement({1,2});
+%union(oo(1,2),oo(2,inf),oo(-inf,1))$
+
+interval_complement(%union(oo(1,2),oo(2,inf),oo(-inf,1)));
+{1,2}$
+
+interval_simple_intersect({1,2,3},{2,3,4});
+{2,3}$
+
+interval_simple_intersect(oo(-5,3.5),{2,3,4});
+{2,3}$
+
+interval_intersect_list([oo(minf,4),oo(-1,10)]);
+oo(-1,4)$
+
+interval_intersect(%union(oo(0,1),oo(1,inf),oo(-inf,0)),%union(oo(2,inf),oo(-inf,2)));
+%union(oo(0,1),oo(1,2), oo(2,inf),oo(-inf,0))$
+
+interval_intersect_list([%union(oo(minf,4),cc(5,6)),oo(-1,10)]);
+%union(oo(-1,4),cc(5,6))$
+
+interval_intersect_list([%union(oo(0,inf),oo(-inf,0)),%union(oo(1,inf),oo(-inf,1)),%union(oo(2,inf),oo(-inf,2)),all]);
+%union(oo(0,1),oo(1,2), oo(2,inf),oo(-inf,0))$
+
+interval_complement(%union(oo(0,1),oo(2,3),oo(3,inf)));
+%union(cc(1,2),{3},oc(-inf,0))$
+
+interval_tidy(%union(oo(minf,0),oo(0,3),%union(cc(3,4),oo(-3,-2))));
+%union(oo(minf,0),oc(0,4))$
diff --git a/stack/2023102700/maxima/rtest_noun_simp.mac b/stack/2023102700/maxima/rtest_noun_simp.mac
new file mode 100644
index 0000000000000000000000000000000000000000..39430fe6497ccc3c869dd2cf6d27e76cbe02aeb6
--- /dev/null
+++ b/stack/2023102700/maxima/rtest_noun_simp.mac
@@ -0,0 +1,208 @@
+zeroAdd(x);
+x$
+zeroAdd(0+x);
+x$
+zeroAdd(0+0+x);
+x$
+zeroAdd(x+0);
+x$
+zeroAdd(0*x);
+0*x$
+zeroAdd(x*0);
+x*0$
+zeroAdd(0^x);
+0^x$
+zeroAdd(x^0);
+x^0$
+
+zeroMul(x);
+x$
+zeroMul(x+0);
+x+0$
+zeroMul(0*x);
+0$
+zeroMul(x*0);
+0$
+zeroMul(0^x);
+0^x$
+zeroMul(x^0);
+x^0$
+zeroMul(0*0*x);
+0$
+zeroMul(sin(0*x));
+sin(0*x)$
+
+oneMul(x);
+x$
+oneMul(x+1);
+x+1$
+oneMul(1*x);
+x$
+oneMul(x*1);
+x$
+oneMul(1^x);
+1^x$
+oneMul(x^1);
+x^1$
+oneMul(1*1*x);
+x$
+oneMul(sin(1*x));
+sin(1*x)$
+
+
+onePow(1);
+1$
+onePow(x^1);
+x^1$
+onePow(1^x);
+1$
+onePow((1+x)^1);
+(1+x)^1$
+onePow(0^1);
+0^1$
+onePow(1^0);
+1$
+
+idPow(1);
+1$
+idPow(x^1);
+x$
+idPow(1^x);
+1^x$
+idPow((1+x)^1);
+(1+x)$
+idPow(0^1);
+0$
+
+zeroPow(1);
+1$
+zeroPow(x^0);
+x^0$
+zeroPow(0^x);
+0$
+zeroPow(0^0);
+0^0$
+zeroPow(1+x);
+1+x$
+zeroPow(0^(x-x));
+0$
+
+zPow(1);
+1$
+zPow(x^0);
+1$
+zPow(0^x);
+0^x$
+zPow(0^0);
+0^0$
+zPow(1+x);
+1+x$
+
+assAdd((a+b)+c);
+a+b+c$
+assAdd(a+(b+c));
+a+b+c$
+assAdd((a+b)+(c+d));
+a+b+c+d$
+
+assMul((a*b)*c);
+a*b*c$
+
+comMul(x);
+x$
+comMul(1);
+1$
+comMul(2*x*3);
+2*3*x$
+comMul(2*3.0*%pi);
+2*3.0*%pi$
+
+
+intAddp(3 nounadd UNARY_MINUS nounmul 2);
+true$
+
+intAdd(1+2);
+3$
+intAdd(1+x+2);
+3+x$
+
+intMul(2*3);
+6$
+intMul(2*x*3);
+6*x$
+intMul(UNARY_MINUS nounmul 2 nounmul UNARY_MINUS nounmul 6);
+12 nounmul UNARY_MINUS nounmul UNARY_MINUS$
+
+intPow(2^3);
+8$
+intPow(2^x);
+2^x$
+intPow(0^0);
+0^0;
+
+intFac(7);
+7$
+intFac(18);
+2 nounmul 3 nounpow 2$
+
+equals_commute_prepare((a/b)/c);
+a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))$
+equals_commute_prepare(a/(b/c));
+a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c))$
+
+divDivp(a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c)))$
+true$
+divDivp(UNARY_RECIP(UNARY_RECIP(b)));
+true$
+divDivp(a nounmul UNARY_RECIP(UNARY_RECIP(b)));
+true$
+divDivp(a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c)));
+false;
+divDivp(UNARY_RECIP(b));
+false$
+divDivp(UNARY_RECIP(b nounmul c));
+false$
+
+divDiv(UNARY_RECIP(UNARY_RECIP(b)));
+b$
+divDiv(a nounmul UNARY_RECIP(UNARY_RECIP(b)));
+a nounmul b$
+divDiv(a nounmul UNARY_RECIP(b nounmul UNARY_RECIP(c)));
+a nounmul c nounmul UNARY_RECIP(b)$
+divDiv(a nounmul UNARY_RECIP(b nounmul B nounmul UNARY_RECIP(c)));
+a nounmul c nounmul UNARY_RECIP(b nounmul B)$
+divDiv(A nounmul a nounmul (UNARY_RECIP(b nounmul UNARY_RECIP(c))) nounmul (UNARY_RECIP(B nounmul UNARY_RECIP(C))));
+A nounmul a nounmul (UNARY_RECIP(B nounmul UNARY_RECIP(C))) nounmul c nounmul UNARY_RECIP(b)$
+
+divDiv(a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c)));
+a nounmul (UNARY_RECIP(b)) nounmul (UNARY_RECIP(c))$
+divDiv(UNARY_RECIP(b));
+UNARY_RECIP(b)$
+divDiv(UNARY_RECIP(b nounmul c));
+UNARY_RECIP(b nounmul c)$
+
+divCancel(a nounmul b nounmul UNARY_RECIP(a nounmul c));
+b nounmul UNARY_RECIP(c)$
+divCancel(a nounmul UNARY_RECIP(a nounmul c));
+UNARY_RECIP(c)$
+divCancel((a nounadd b) nounmul UNARY_RECIP(a nounadd c));
+(a nounadd b) nounmul UNARY_RECIP(a nounadd c)$
+divCancel(A nounmul (a nounadd b) nounmul UNARY_RECIP(a nounadd b));
+A$
+divCancel(UNARY_MINUS nounmul a nounmul UNARY_RECIP(UNARY_MINUS nounmul b));
+a nounmul UNARY_RECIP(b)$
+
+negDist(UNARY_MINUS nounmul x nounmul (UNARY_MINUS nounmul x nounadd 1));
+(UNARY_MINUS nounmul (UNARY_MINUS nounmul x) nounadd UNARY_MINUS nounmul 1) nounmul x$
+
+negOrd(a+UNARY_MINUS nounmul b);
+a + UNARY_MINUS nounmul b$
+
+negOrd(b+UNARY_MINUS nounmul a);
+UNARY_MINUS nounmul (UNARY_MINUS nounmul b+a)$
+
+negOrd(b+UNARY_MINUS nounmul 3 nounmul a);
+b+UNARY_MINUS nounmul 3 nounmul a$
+
+negOrd(b+UNARY_MINUS nounmul a+c);
+UNARY_MINUS nounmul (UNARY_MINUS nounmul b+a+UNARY_MINUS nounmul c)$
diff --git a/stack/2023102700/maxima/s_test_case.lisp b/stack/2023102700/maxima/s_test_case.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a2f0b3d56e179ad6b03be623630558a49c4465e5
--- /dev/null
+++ b/stack/2023102700/maxima/s_test_case.lisp
@@ -0,0 +1,4 @@
+;; Needed to read in files as textfiles.
+(defun readline (stream) (read-line stream nil nil))
+
+
diff --git a/stack/2023102700/maxima/s_test_case.mac b/stack/2023102700/maxima/s_test_case.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e96ef5a14b4e989d11aca2e83b3dc4a822e8e085
--- /dev/null
+++ b/stack/2023102700/maxima/s_test_case.mac
@@ -0,0 +1,65 @@
+/* Author Chris Sangwin
+ Copyright (C) 2023 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* ******************************************************** */
+/* Run STACK packages bespoke maxima unit tests. */
+/* */
+/* To use this in the sandbox try something like */
+/* */
+/* stacklocation:"/var/www/html/m40/question/type/stack"$ */
+/* load("s_test_case.mac"); */
+/* ******************************************************** */
+
+print("************ s_test_case results.");
+
+load("s_test_case.lisp")$
+s_test_case_eval(ex1, ex2):= if(is(ex1=ex2)) then true else sconcat("Expected '", string(ex2), "' but got '", string(ex1), "'.");
+
+read_s_test_file(filename) := block([filedescr, stream, oneline, soneline, eof, cnt, s_failing],
+ /* Load the file to define any functions etc. it contains. */
+ load(filename),
+ /* A list to hold test cases which fail. */
+ s_failing:[],
+ eof: false,
+ filedescr:file_search(filename),
+ stream: ?open(filedescr),
+ while not eof do block(
+ oneline: ?readline(stream),
+ soneline: strim(" ", string(oneline)),
+ if is(slength(soneline)>12) and is(substring(soneline, 1, 13)="\"s_test_case") then block([ex],
+ ex:parse_string(oneline),
+ ex:ev(ex, s_test_case=s_test_case_eval),
+ if stringp(ex) then s_failing:append(s_failing, [[oneline, ex]])
+ ),
+ eof: not(?stringp(oneline))
+ ),
+ if emptyp(s_failing) then print(sconcat("All passed for: ", filename)) else block(
+ print(sconcat("FAILED in: ", filename)),
+ print(s_failing)
+ )
+ )$
+
+/* Automatically find files in the contrib directory. */
+contrib_files:directory(sconcat(stacklocation, "/stack/maxima/contrib/*.mac"))$
+
+if emptyp(contrib_files) then print("WARNING: you need to redefine the stacklocation variable correctly to run the tests!");
+
+print("simp:false");
+simp:false;
+
+/* Load files in the contrib directory and run the tests. */
+while not(emptyp(contrib_files)) do block(
+ read_s_test_file(first(contrib_files)),
+ contrib_files:rest(contrib_files)
+ );
diff --git a/stack/2023102700/maxima/sandbox.wxm b/stack/2023102700/maxima/sandbox.wxm
new file mode 100644
index 0000000000000000000000000000000000000000..d26ca4fd66808617c20db5d42b05a0508418d965
--- /dev/null
+++ b/stack/2023102700/maxima/sandbox.wxm
@@ -0,0 +1,107 @@
+/* [wxMaxima batch file version 1] [ DO NOT EDIT BY HAND! ]*/
+/* [ Created with wxMaxima version 20.12.1 ] */
+/* [wxMaxima: title start ]
+STACK Sandbox
+ [wxMaxima: title end ] */
+
+
+/* [wxMaxima: comment start ]
+This workbook allows you to use the STACK libraries with desktop Maxima.
+See https://docs.stack-assessment.org/en/CAS/STACK-Maxima_sandbox
+The source code is at https://github.com/maths/moodle-qtype_stack
+
+1. Clone/downlod the source code of STACK. E.g. https://github.com/maths/moodle-qtype_stack/archive/master.zip
+2. Set your operating system with the variable maximaplatform. For Windows set it to "win".
+3. Set the stacklocation variable below to the location of the STACK source code you downloaded, e.g. c:/tmp/stackroot
+4. Specify a directory for temporary working files, e.g. /tmp or C:/tmp
+
+[Directories in 2 & 3 can be the same if you don't mind clutter.]
+
+Note that plots *will not work* in this sandbox.
+ [wxMaxima: comment end ] */
+
+
+/* [wxMaxima: input start ] */
+/* For MS platforms you normally need to explicitly set the path.
+ This assumes you have cloned/downloaed the STACK code into c:/tmp/stackroot
+ E.g. this file must exist c:/tmp/stackroot/stackmaxima.mac
+
+ Use the forward slash as a directory seperator.
+ No trailing slash.
+*/
+maximaplatform:"win"$
+stacklocation:"c:/tmp/stackroot"$
+stacktmplocation:"c:/tmp"$
+
+/*maximaplatform:"linux"$
+stacklocation:"."$
+stacktmplocation:"/tmp"$
+*/
+
+/****************************************************
+ There should be no need to edit below this line.
+
+ These commands add the location to Maxima's search path.
+*/
+file_search_maxima:append( [sconcat(stacklocation, "/stack/maxima/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/stack/maxima/###.{lisp}")] , file_search_lisp)$
+file_search_maxima:append( [sconcat(stacklocation, "/stack/maxima/contrib/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacklocation, "/stack/maxima/contrib/###.{lisp}")] , file_search_lisp)$
+file_search_maxima:append( [sconcat(stacktmplocation, "/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat(stacktmplocation, "/###.{lisp}")] , file_search_lisp)$
+
+/*
+ The following command may be slightly different on your particular server.
+ There is normally no need to change this. You can see this function on the STACK healtcheck page (moodle admin access only).
+*/
+STACK_SETUP(ex):=block(
+ MAXIMA_VERSION_NUM_EXPECTED:0,
+ MAXIMA_PLATFORM:maximaplatform,
+ maxima_tempdir:"",
+ IMAGE_DIR:"",
+ PLOT_SIZE:[450,300],
+ PLOT_TERMINAL:"svg",
+ PLOT_TERM_OPT:"dynamic font \",11\" linewidth 1.2",
+ DEL_CMD:"rm",
+ GNUPLOT_CMD:"gnuplot",
+ MAXIMA_VERSION_EXPECTED:"default",
+ URL_BASE:"!ploturl!",
+ /* Define units available in STACK. */
+ stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y],
+ stack_unit_si_prefix_multiplier:[10^-24, 10^-21, 10^-18, 10^-15, 10^-12, 10^-9, 10^-6, 10^-3, 10^-2, 10^-1, 10, 10^2, 10^3, 10^6, 10^9, 10^12, 10^15, 10^18, 10^21, 10^24],
+ stack_unit_si_prefix_tex:["\\mathrm{y}", "\\mathrm{z}", "\\mathrm{a}", "\\mathrm{f}", "\\mathrm{p}", "\\mathrm{n}", "\\mu ", "\\mathrm{m}", "\\mathrm{c}", "\\mathrm{d}", "\\mathrm{da}", "\\mathrm{h}", "\\mathrm{k}", "\\mathrm{M}", "\\mathrm{G}", "\\mathrm{T}", "\\mathrm{P}", "\\mathrm{E}", "\\mathrm{Z}", "\\mathrm{Y}"],
+ stack_unit_si_unit_code:[m, l, L, g, t, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, Wh, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, lx, lm, mol, M, kat, rad, sr, K, VA, eV, Ci],
+ stack_unit_si_unit_conversions:[m, m^3/1000, m^3/1000, kg/1000, 1000*kg, s, s*3600, 1/s, 1/s, cd, (kg*m)/s^2, kg/(m*s^2), 4.2*J, 4200*J, 1055*J, 1.602177e-19*J, (kg*m^2)/s^2, (kg*m^2)/s^3, 3600*(kg*m^2)/s^2, A, (kg*m^2)/(s^3*A^2), s*A, (kg*m^2)/(s^3*A), (s^4*A^2)/(kg*m^2), (s^3*A^2)/(kg*m^2), (kg*m^2)/(s^2*A), kg/(s^2*A), (kg*m^2)/(s^2*A^2), m^2/s^2, 0.01*Sv, m^2/s^2, cd/m^2, cd, mol, mol/(m^3/1000), mol/s, rad, sr, K, (kg*m^2)/(s^3), 1.602176634E-19*J, Ci],
+ stack_unit_si_unit_tex:["\\mathrm{m}", "\\mathrm{l}", "\\mathrm{L}", "\\mathrm{g}", "\\mathrm{t}", "\\mathrm{s}", "\\mathrm{h}", "\\mathrm{Hz}", "\\mathrm{Bq}", "\\mathrm{cd}", "\\mathrm{N}", "\\mathrm{Pa}", "\\mathrm{cal}", "\\mathrm{cal}", "\\mathrm{Btu}", "\\mathrm{eV}", "\\mathrm{J}", "\\mathrm{W}", "\\mathrm{Wh}", "\\mathrm{A}", "\\Omega", "\\mathrm{C}", "\\mathrm{V}", "\\mathrm{F}", "\\mathrm{S}", "\\mathrm{Wb}", "\\mathrm{T}", "\\mathrm{H}", "\\mathrm{Gy}", "\\mathrm{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{lm}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}", "\\mathrm{sr}", "\\mathrm{K}", "\\mathrm{VA}", "\\mathrm{eV}", "\\mathrm{Ci}"],
+ stack_unit_other_unit_code:[min, amu, u, mmHg, bar, ha, cc, gal, mbar, atm, torr, rev, deg, rpm, au, Da, Np, B, dB, day, year, hp, in, ft, yd, mi, lb],
+ stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 10^4*m^2, m^3*10^(-6), 3.785*l, 10^2*Pa, 101325*Pa, 101325/760*Pa, 2*pi*rad, pi*rad/180, pi*rad/(30*s), 149597870700*m, 1.660539040E-27*kg, Np, B, dB, 86400*s, 3.156e7*s, 746*W, in, 12*in, 36*in, 5280*12*in, 4.4482*N],
+ stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{ha}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{au}", "\\mathrm{Da}", "\\mathrm{Np}", "\\mathrm{B}", "\\mathrm{dB}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{hp}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{yd}", "\\mathrm{mi}", "\\mathrm{lb}"],
+ true)$
+
+/* Load the main libraries. */
+load("stackmaxima.mac")$
+load("stats")$
+load("distrib")$
+load("descriptive")$
+alias(stack_include_contrib, load)$
+
+print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$
+/* [wxMaxima: input end ] */
+
+
+/* [wxMaxima: input start ] */
+
+/* [wxMaxima: input end ] */
+
+
+/* [wxMaxima: input start ] */
+/* Optional but useful. */
+display2d:true;
+simp:false;
+debug:true;
+/* [wxMaxima: input end ] */
+
+
+
+/* Old versions of Maxima abort on loading files that end in a comment. */
+"Created with wxMaxima 20.12.1"$
diff --git a/stack/2023102700/maxima/stack44.mac b/stack/2023102700/maxima/stack44.mac
new file mode 100644
index 0000000000000000000000000000000000000000..1842d1534a72c8c5ecd08bf5d090af0f4de05328
--- /dev/null
+++ b/stack/2023102700/maxima/stack44.mac
@@ -0,0 +1,12 @@
+/*load("sqdnst")*/
+sqrtdenest(a) :=
+ subst("^" = lambda([a, b],
+ block([discr, max, min],
+ if evenp(denom(b)) and not atom(a) and inpart(a, 0) = "+"
+ and (max:max(first(a), rest(a)),
+ min:a-max,
+ numberp(discr:sqrt(1-(min/max)^2)))
+ then (sqrt(max*(1+discr)/2)+signum(min)*sqrt(max*(1-discr)/2))^(2*b)
+ else a^b)),
+ a
+)$
\ No newline at end of file
diff --git a/stack/2023102700/maxima/stack_logic.lisp b/stack/2023102700/maxima/stack_logic.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..85b0b526073c072e7abe0b51d0c536b05a568df6
--- /dev/null
+++ b/stack/2023102700/maxima/stack_logic.lisp
@@ -0,0 +1,682 @@
+#|
+; logic.mac--Logic algebra package for Maxima CAS.
+; Copyright (c) 2008--2009 Alexey Beshenov <al@beshenov.ru>.
+;
+; Version 2.11. Last modified 2009-01-07.
+;
+; logic.mac is free software; you can redistribute it and/or modify it
+; under the terms of the GNU Lesser General Public License as published
+; by the Free Software Foundation; either version 2.1 of the License,
+; or (at your option) any later version.
+;
+; logic.mac is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with the logic.mac; see the file COPYING. If not, write to the
+; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+; Boston, MA 02110-1301, USA.
+|#
+
+
+(defvar $logic_mac_version 2.11)
+
+(defvar use-maxima-logic-operators t)
+
+(if use-maxima-logic-operators
+ (progn
+ (defvar *not-op* 'mnot)
+ ($texput "not" " \\neg " '$prefix)
+ (defvar *and-op* 'mand)
+ ($texput "and" " \\wedge " '$nary)
+ (defvar *or-op* 'mor)
+ ($texput "or" " \\vee " '$nary))
+ (progn
+ ($prefix "log-not" 70)
+ (defvar *not-op* '$log-not)
+ ($texput "log-not" " \\neg " '$prefix)
+ ($nary "log-and" 65)
+ (defvar *and-op* '$log-and)
+ ($texput "log-and" " \\wedge " '$nary)
+ ($nary "log-or" 60)
+ (defvar *or-op* '$log-or)
+ ($texput "log-or" " \\vee " '$nary)))
+
+($nary "nand" 62)
+(defvar *nand-op* '$nand)
+($texput "nand" " \\mid " '$nary)
+
+($nary "nor" 61)
+(defvar *nor-op* '$nor)
+($texput "nor" " \\downarrow " '$nary)
+
+($infix "implies" 59)
+(defvar *implies-op* '$implies)
+($texput "implies" " \\rightarrow " '$infix)
+
+($nary "xnor" 58)
+(defvar *eq-op* '$xnor)
+($texput "xnor" " \leftrightarrow " '$nary)
+
+($nary "xor" 58)
+(defvar *xor-op* '$xor)
+($texput "xor" " \\oplus " '$nary)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun get-maxima-operator (expr)
+ (if (and (listp expr) expr (listp (car expr)) (car expr))
+ (caar expr)
+ nil))
+
+(defun contains-operator (expr op)
+ (let
+ ((o (get-maxima-operator expr)) args)
+ (setf args (if o (cdr expr) nil))
+ (if
+ (eq o op)
+ t
+ (member t (mapcar #'(lambda (e) (contains-operator e op)) args)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; maxima versions >=5.43 have an internal cartesian-product function
+; incompatible with this function, therefore we only define it if
+; previously undefined
+(unless (fboundp 'cartesian-product)
+ (defun cartesian-product (l1 l2)
+ (if l1
+ (append
+ (mapcar #'(lambda (e) (cons (car l1) e)) l2)
+ (cartesian-product (cdr l1) l2))
+ nil)))
+
+(defun replicate (n e)
+ (if (and (integerp n) (>= n 0))
+ (if (= n 0) nil (cons e (replicate (1- n) e)))
+ (error "Invalid arguments to 'replicate'")))
+
+(defun zip (l1 l2)
+ (if (or (not (listp l1)) (not (listp l2)) (/= (length l1) (length l2)))
+ (error "Invalid arguments to 'zip'"))
+ (if (null l1)
+ l1
+ (cons (cons (car l1) (car l2)) (zip (cdr l1) (cdr l2)))))
+
+(defun remove-nth (n l)
+ (cond
+ ((or (not (integerp n)) (< n 0)) (error "Invalid argumet to 'remove-nth'"))
+ ((= n 0) (cdr l))
+ (t (cons (car l) (remove-nth (1- n) (cdr l))))))
+
+(defun multiset-to-hash (l)
+ (mapcar
+ #'(lambda (e) (list e (count e l :test 'equal)))
+ (remove-duplicates l :test 'equal)))
+
+(defun hash-to-multiset (h)
+ (mapcan (lambda (he) (replicate (second he) (first he))) h))
+
+(defun cancel-pairs-in-hash (h)
+ (mapcar (lambda (he) (list (first he) (mod (second he) 2))) h))
+
+(defun cancel-pairs (l)
+ (hash-to-multiset (cancel-pairs-in-hash (multiset-to-hash l))))
+
+(defun subst-recursive (expr pairs)
+ (if pairs
+ (let ((p (car pairs)))
+ (subst (cdr p) (car p) (subst-recursive expr (cdr pairs))))
+ expr))
+
+(defun disjoin-list (pred lst)
+ (if (null lst)
+ '(nil nil)
+ (let ((dl (disjoin-list pred (cdr lst))))
+ (if (funcall pred (car lst))
+ (list (cons (car lst) (first dl)) (second dl))
+ (list (first dl) (cons (car lst) (second dl)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; t or nil
+(defun booleanp (x)
+ (or (eq x t) (eq x nil)))
+
+(defun logic-sort-comparator (x y)
+ (cond
+ ((and (not (booleanp x)) (booleanp y)) t)
+ ((and (booleanp x) (not (booleanp y))) nil)
+ ((and (not (listp x)) (listp y)) nil)
+ ((and (listp x) (not (listp y))) t)
+ ((and (listp x) (listp y) (< (length x) (length y))) nil)
+ ((and (listp x) (listp y) (> (length x) (length y))) t)
+ (t ($orderlessp x y))))
+
+(defun sort-symbols (seq)
+ (sort seq 'logic-sort-comparator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; op (x_1, ..., f(y_1, ..., y_m), ..., x_n) =>
+; op (x_1, ..., y_1, ..., y_m, ..., x_n)
+(defun flatten-nested (args op)
+ (let
+ ((nested-exprs nil)
+ (other nil))
+ (loop while args do
+ (if
+ (eq (get-maxima-operator (car args)) op)
+ (setq nested-exprs (cons (car args) nested-exprs))
+ (setq other (cons (car args) other)))
+ (setq args (cdr args)))
+ (setq
+ nested-exprs
+ (mapcar #'(lambda (e) (flatten-nested (cdr e) op)) nested-exprs))
+ (if nested-exprs
+ (append other (apply 'append nested-exprs))
+ other)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Logic functions
+
+; Implication
+(defun simp-implies (x y)
+ (cond
+ ((eq x nil) t)
+ ((and (eq x t) (eq y t)) t)
+ ((and (eq x t) (eq y nil)) nil)
+ (t (list (list *implies-op* 'simp) x y))))
+
+; Webb-operation or Peirce arrow (Quine's dagger, NOR)
+(defun simp-nor (&rest args)
+ (if
+ (member t args)
+ (return-from simp-nor nil))
+ (setf args (remove-duplicates (remove nil args) :test 'equal))
+ (cond
+ ((null args) t)
+ ((eq (length args) 1) (simp-not (car args)))
+ (t (cons (list *nor-op* 'simp) (sort-symbols args)))))
+
+; Sheffer stroke (alternative denial, NAND)
+(defun simp-nand (&rest args)
+ (if
+ (member nil args)
+ (return-from simp-nand t))
+ (setf args (remove-duplicates (remove t args) :test 'equal))
+ (cond
+ ((null args) nil)
+ ((eq (length args) 1) (simp-not (car args)))
+ (t (cons (list *nand-op* 'simp) (sort-symbols args)))))
+
+; Equivalence
+(defun simp-eq (&rest args)
+ (setf args (cancel-pairs (remove t (flatten-nested args *eq-op*))))
+ (cond
+ ((null args) t)
+ ((eq (length args) 1) (car args))
+ (t (cons (list *eq-op* 'simp) (sort-symbols args)))))
+
+; Sum modulo 2 (exclusive or)
+(defun simp-xor (&rest args)
+ (setf args (cancel-pairs (remove nil (flatten-nested args *xor-op*))))
+ (cond
+ ((null args) nil)
+ ((eq (length args) 1) (car args))
+ (t (cons (list *xor-op* 'simp) (sort-symbols args)))))
+
+; returns t if args = (... x ... not x ...)
+; used in simp-and and simp-or
+(defun x-not-x (args)
+ (let
+ ((neg
+ (disjoin-list
+ #'(lambda (e) (eq (get-maxima-operator e) *not-op*)) args)))
+ (not
+ (null
+ (intersection
+ (mapcar 'cadr (first neg)) (second neg) :test 'equal)))))
+
+; Logical AND (conjunction)
+(defun simp-and (&rest args)
+ (setf args (flatten-nested args *and-op*))
+ (if
+ (member nil args)
+ (return-from simp-and nil))
+ (setf args (remove-duplicates (remove t args) :test 'equal))
+ (cond
+ ((null args) t)
+ ((eq (length args) 1) (car args))
+ (t
+ (if (x-not-x args)
+ nil
+ (cons (list *and-op* 'simp) (sort-symbols args))))))
+
+; Logical OR (disjunction)
+(defun simp-or (&rest args)
+ (setf args (flatten-nested args *or-op*))
+ (if
+ (member t args)
+ (return-from simp-or t))
+ (setf args (remove-duplicates (remove nil args) :test 'equal))
+ (cond
+ ((null args) nil)
+ ((eq (length args) 1) (car args))
+ (t
+ (if (x-not-x args)
+ t
+ (cons (list *or-op* 'simp) (sort-symbols args))))))
+
+; Logical NOT (negation)
+(defun simp-not (x)
+ (cond
+ ((eq (get-maxima-operator x) *not-op*) (cadr x))
+ ((eq x nil) t)
+ ((eq x t) nil)
+ (t (list (list *not-op* 'simp) x))))
+
+(defun apply-op (op args)
+ (cond
+ ((eq op *and-op*) (apply 'simp-and args))
+ ((eq op *xor-op*) (apply 'simp-xor args))
+ ((eq op *not-op*) (apply 'simp-not args))
+ ((eq op *or-op*) (apply 'simp-or args))
+ ((eq op *nor-op*) (apply 'simp-nor args))
+ ((eq op *nand-op*) (apply 'simp-nand args))
+ ((eq op *eq-op*) (apply 'simp-eq args))
+ ((eq op *implies-op*) (apply 'simp-implies args))
+ (t (cons (list op) args))))
+
+(defun logic-simp (expr)
+ (let
+ ((op (get-maxima-operator expr)) args)
+ (setf args (if op (mapcar 'logic-simp (cdr expr)) nil))
+ (if op
+ (apply-op op args)
+ expr)))
+
+(defun $logic_simp (expr) (logic-simp expr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|
+;
+; (all-charfuns 1) => ((nil) (t))
+;
+; (all-charfuns 2) => ((nil nil) (nil t) (t nil) (t t))
+;
+; (all-charfuns 3) => ((nil nil nil) (nil nil t) (nil t nil) (nil t t)
+; (t nil nil) (t nil t) (t t nil) (t t t))
+;
+; ...
+;
+|#
+
+(defun all-charfuns (n)
+ (if (not (and (integerp n) (>= n 1)))
+ (error "Invalid argument to 'all-charfuns'"))
+ (cond
+ ((= n 1) '((nil) (t)))
+ (t
+ (let
+ ((pre (all-charfuns (1- n))))
+ (append
+ (mapcar (lambda (l) (cons nil l)) pre)
+ (mapcar (lambda (l) (cons t l)) pre))))))
+
+; List of values for all-charfuns, 2^n elements
+(defun characteristic-vector (expr &rest args)
+ (if (null args)
+ (setf args (list-of-variables expr)))
+ (if (null args)
+ (list expr)
+ (let (vals (n (length args)))
+ (setf vals (mapcar #'(lambda (l) (zip args l)) (all-charfuns n)))
+ (mapcar #'(lambda (v) (logic-simp (subst-recursive expr v))) vals))))
+
+(defun list-of-variables (expr)
+ (sort-symbols (cdr ($listofvars expr))))
+
+(defun $characteristic_vector (expr &rest args)
+ (cons '(mlist simp) (apply 'characteristic-vector (cons expr args))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Conversion to the Zhegalkin basis {and, xor}
+(defun zhegalkin-basis-substitute (expr)
+ (let
+ ((op (get-maxima-operator expr)) args)
+ (setf args (if op (mapcar 'zhegalkin-basis-substitute (cdr expr)) nil))
+ (cond
+ ; not x => x xor t
+ ((eq op *not-op*) (simp-xor (car args) t))
+ ; x implies y => (x and y) xor x xor t
+ ((eq op *implies-op*)
+ (simp-xor (apply 'simp-and args) (first args) t))
+ ; x1 nand x2 nand x3 ... nand xn => (x1 and x2 and x3 ... and xn) xor t
+ ((eq op *nand-op*) (simp-xor (apply 'simp-and args) t))
+ ; x nor y => (x or y) xor t
+ ((eq op *nor-op*)
+ (simp-xor
+ (zhegalkin-basis-substitute (simp-or (first args) (second args)))
+ t))
+ ; x or y => (x and y) xor x xor y
+ ((eq op *or-op*)
+ (let (zhegform)
+ (setf zhegform
+ (simp-xor
+ (simp-and (first args) (second args))
+ (first args) (second args)))
+ (setf args (cddr args))
+ (loop while args do
+ (setf zhegform
+ (simp-xor
+ (simp-and zhegform (car args))
+ zhegform
+ (car args)))
+ (setf args (cdr args)))
+ zhegform))
+ ; a eq b => a xor b xor t
+ ; a eq b eq c => a xor b xor c
+ ; a eq b eq c eq d => a xor b xor c xor d xor t
+ ; a eq b eq c eq d eq e => a xor b xor c xor d xor e
+ ; ...
+ ((eq op *eq-op*)
+ (apply 'simp-xor
+ (if (evenp (length args)) (cons t args) args)))
+ (op (apply-op op args))
+ (t expr))))
+
+; acts like Maxima "expand" on ordinary polynomial ring,
+; but on Zhegalkin polynomials
+(defun zhegalkin-basis-expand (expr)
+ (let
+ ((op (get-maxima-operator expr)) args)
+ (setf args (if op (mapcar 'zhegalkin-basis-expand (cdr expr)) nil))
+ (cond
+ ((eq op *and-op*)
+ (let
+ ((xor-expression
+ (find-if
+ (lambda (e) (eq (get-maxima-operator e) *xor-op*))
+ (cdr expr))))
+ (if xor-expression
+ (let
+ ((xor-args (cdr xor-expression))
+ (and-args
+ (remove xor-expression (cdr expr) :test 'equal)))
+ (zhegalkin-basis-expand
+ (apply 'simp-xor
+ (mapcar
+ (lambda (e) (apply 'simp-and (cons e and-args)))
+ xor-args))))
+ expr)))
+ ((eq op *xor-op*) (apply 'simp-xor args))
+ (t expr))))
+
+(defun $zhegalkin_form (expr)
+ (zhegalkin-basis-expand (zhegalkin-basis-substitute expr)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun $logic_equiv (expr1 expr2)
+ (equal
+ ($zhegalkin_form expr1)
+ ($zhegalkin_form expr2)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun subst-not (expr)
+ (let
+ ((op (get-maxima-operator expr)))
+ (if op
+ (cons (list op) (mapcar 'subst-not (cdr expr)))
+ (simp-not expr))))
+
+; f^* (x_1, ..., x_n) = not f (not x_1, ..., not x_n)
+(defun $dual_function (expr)
+ (logic-simp (simp-not (subst-not expr))))
+
+; f = f^*
+(defun $self_dual (expr)
+ ($logic_equiv expr ($dual_function expr)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun closed-under (expr x)
+ (let
+ (val n (args (list-of-variables expr)))
+ (setf n (length args))
+ (setf val (zip args (replicate n x)))
+ (eq (logic-simp (subst-recursive expr val)) x)))
+
+; f (nil, ..., nil) = nil
+(defun $closed_under_f (expr)
+ (closed-under expr nil))
+
+; f (t, ..., t) = t
+(defun $closed_under_t (expr)
+ (closed-under expr t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun $monotonic (expr &rest args)
+ (let
+ (prev-value (charvec (apply 'characteristic-vector (cons expr args))))
+ (if charvec
+ (progn
+ (setf prev-value (car charvec))
+ (setf charvec (cdr charvec))
+ (loop while charvec do
+ (if
+ (and
+ (eq (car charvec) nil)
+ (eq prev-value t))
+ (return-from $monotonic nil))
+ (setf prev-value (car charvec))
+ (setf charvec (cdr charvec)))
+ t)
+ t)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun $linear (expr)
+ (not (contains-operator ($zhegalkin_form expr) *and-op*)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Post's theorem
+
+(defun post-table (&rest expressions)
+ (mapcar
+ (lambda (fn) (mapcar fn expressions))
+ '($self_dual $closed_under_f $closed_under_t $linear $monotonic)))
+
+(defun functionally-complete (table)
+ (if
+ (null table)
+ (return-from functionally-complete nil))
+ (loop while table do
+ (if
+ (not (member nil (car table)))
+ (return-from functionally-complete nil))
+ (setf table (cdr table)))
+ t)
+
+(defun $functionally_complete (&rest expressions)
+ (functionally-complete (apply 'post-table expressions)))
+
+; Basis is a complete system without redundant functions
+(defun $logic_basis (&rest expressions)
+ (let
+ ((table (apply 'post-table expressions))
+ (n (length expressions)))
+ (if (functionally-complete table)
+ (if (= n 1)
+ (return-from $logic_basis t))
+ (return-from $logic_basis nil))
+ (loop for i from 0 to (1- n) do
+ (if
+ (functionally-complete
+ (mapcar (lambda (e) (remove-nth i e)) table))
+ (return-from $logic_basis nil)))
+ t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Logic differentiation
+
+#|
+;
+; dy
+; (1) --- = false
+; dx
+;
+; where y is a variable which not depends on x.
+;
+;
+; dx
+; (2) --- = true
+; dx
+;
+;
+; d
+; (3) --- [x and ... and x ] = x and x ... and x
+; dx 1 n 2 3 n
+; 1
+;
+;
+; d df dg
+; (4) -- [g xor f] = -- xor --
+; dx dx dx
+;
+;
+; TODO: higher orders / mixed
+;
+|#
+
+(defun diff-zhegalkin-form (expr x)
+ (let ((op (get-maxima-operator expr)))
+ (cond
+ ((null op) (eq expr x))
+ ((eq op *xor-op*)
+ (apply
+ 'simp-xor
+ (mapcar #'(lambda (e) (diff-zhegalkin-form e x)) (cdr expr))))
+ ((eq op *and-op*)
+ (let ((args (cdr expr)))
+ (if (member x args) (apply 'simp-and (remove x args)) nil)))
+ (t (error "Not a Zhegalkin form in diff-zhegalkin-form: '~s'" expr)))))
+
+(defun $logic_diff (expr x)
+ (diff-zhegalkin-form ($zhegalkin_form expr) x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Coversion to the Boolean basis {and, or, not}
+(defun boolean-basis-substitute (expr)
+ (let
+ ((op (get-maxima-operator expr)) args)
+ (setf args (if op (mapcar 'boolean-basis-substitute (cdr expr)) nil))
+ (cond
+ ; x implies y => (not x) or y
+ ((eq op *implies-op*) (simp-or (simp-not (first args)) (second args)))
+ ; x1 nand ... nand xn => not (x1 and ... and xn)
+ ((eq op *nand-op*) (simp-not (apply 'simp-and args)))
+ ; x1 nor ... not xn => not (x1 or ... or xn)
+ ((eq op *nor-op*) (simp-not (apply 'simp-or args)))
+ ; x eq b => ((not x) or y) and ((not y) or x)
+ ((eq op *eq-op*)
+ (let (boolform)
+ (setf boolform
+ (simp-and
+ (simp-or (simp-not (first args)) (second args))
+ (simp-or (simp-not (second args)) (first args))))
+ (setf args (cddr args))
+ (loop while args do
+ (setf boolform
+ (simp-and
+ (simp-or (simp-not boolform) (car args))
+ (simp-or (simp-not (car args)) boolform)))
+ (setf args (cdr args)))
+ boolform))
+ ; x xor y => ((not x) and y) or ((not y) and x)
+ ((eq op *xor-op*)
+ (let (boolform)
+ (setf boolform
+ (simp-or
+ (simp-and (simp-not (first args)) (second args))
+ (simp-and (simp-not (second args)) (first args))))
+ (setf args (cddr args))
+ (loop while args do
+ (setf boolform
+ (simp-or
+ (simp-and (simp-not boolform) (car args))
+ (simp-and (simp-not (car args)) boolform)))
+ (setf args (cdr args)))
+ boolform))
+ (op (apply-op op args))
+ (t expr))))
+
+(defun $boolean_form (expr)
+ (boolean-basis-substitute expr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; De Morgan's rules
+(defun $demorgan (expr)
+ (let
+ ((op (get-maxima-operator expr)) args)
+ (setf args (if op (mapcar '$demorgan (cdr expr)) nil))
+ (cond
+ ((eq op *not-op*)
+ (let ((op-op (get-maxima-operator (car args))))
+ (cond
+ ((eq op-op *and-op*) (apply 'simp-or (mapcar 'simp-not (cdar args))))
+ ((eq op-op *or-op*) (apply 'simp-and (mapcar 'simp-not (cdar args))))
+ (t (apply 'simp-not args)))))
+ ((null op) expr)
+ (t (apply-op op args)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Perfect disjunctive normal forms
+
+(defun elementary-conjunct-disjunct (vars-vals b)
+ (if (null vars-vals)
+ nil
+ (cons
+ (if (eq (cdar vars-vals) b)
+ (caar vars-vals)
+ (list (list *not-op* 'simp) (caar vars-vals)))
+ (elementary-conjunct-disjunct (cdr vars-vals) b))))
+
+(defun pdnf-pcnf (expr b)
+ (let ((args (list-of-variables expr)))
+ (if (null args)
+ expr
+ (let (vals (n (length args)) (result nil))
+ (setf vals (mapcar #'(lambda (l) (zip args l)) (all-charfuns n)))
+ (loop while vals do
+ (if (eq (logic-simp (subst-recursive expr (car vals))) b)
+ (setf result
+ (cons
+ (apply (if b 'simp-and 'simp-or)
+ (elementary-conjunct-disjunct (car vals) b))
+ result)))
+ (setf vals (cdr vals)))
+ (apply (if b 'simp-or 'simp-and) result)))))
+
+; Perfect disjunctive normal form
+(defun $pdnf (expr)
+ (pdnf-pcnf expr t))
+
+; Perfect conjunctive normal form
+(defun $pcnf (expr)
+ (pdnf-pcnf expr nil))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/stack/2017121800/maxima/stackmaxima.mac b/stack/2023102700/maxima/stackmaxima.mac
similarity index 59%
rename from stack/2017121800/maxima/stackmaxima.mac
rename to stack/2023102700/maxima/stackmaxima.mac
index f7429bccf081237061a799f3148100a215052d7d..02627e05fdfac00005c9675e487eb4643d780e60 100644
--- a/stack/2017121800/maxima/stackmaxima.mac
+++ b/stack/2023102700/maxima/stackmaxima.mac
@@ -19,7 +19,8 @@
/* Global variable options */
/* ********************************** */
-stack_reset(rand_seed) := block(
+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
@@ -34,6 +35,9 @@ stack_reset(rand_seed) := block(
exptdispflag: true,
linsolvewarn: false,
ratprint: false,
+ factor_max_degree_print_warning:false,
+ /* Suppress warnings printed by mtell, e.g. by solve, rat and other functions. */
+ stack_mtell_quiet:false,
fpprintprec: 12, /* Print only 12 digits. */
fpprec: 20, /* Work with 20 digits. */
%E_TO_NUMLOG: true, /* "r" some rational number, and "x" some expression, %E^(r*LOG(x)) => x^r .*/
@@ -45,20 +49,26 @@ stack_reset(rand_seed) := block(
pi() := %pi, /* Why does Excel do this?! */
/* Display of matrixes */
lmxchar: "[",
- /* Sets up randomization, using Maxima's internal random command */
+ /* 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(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 else 0)),
+ MAXIMA_VERSION_NUM: float(MAXIMA_VERSION[2]+(if is(length(MAXIMA_VERSION)>2)
+ then (if is(MAXIMA_VERSION[3]<10) then MAXIMA_VERSION[3]/10 else 0) else 0)),
OPT_OUTPUT: "LaTeX",
PLOT_TAGS: true,
+ /* Records the number of the plot. */
+ STACK_PLOT_UNIQUE_NUMBER: 0,
+
true
)$
@@ -66,20 +76,63 @@ stack_reset(rand_seed) := block(
stack_reset_vars(ex) := block(kill(i, j, e, pi, Pi, PI));
/* Execute this command to ensure values have been set. */
-stack_reset(1000);
+stack_reset(true);
-alias(int,integrate); /* Allows integrate to be called with int() */
-alias(cosec,csc); /* Corresponds to current student expectations */
+/* Make sure this is at least defined. */
+debug:false;
-simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
-degree(ex,v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
+/* TODO: remove this from install process. */
+/* ********************************************************************* */
+/* Evaluate variables are return errors, display, and content forms. */
+/* ********************************************************************* */
+/* This function executes ex, which is assumed to be a stack expression */
+/* which is surrounded by errcatch. Hence we end up with a list. */
+cte(var, ex) := block([str],
+ print("], key = ["),
+ print(var),
+ print("]"),
+ if ex = [] then block(
+ ex:STACKERROR,
+ print(", value = [], display = []")
+ )
+ else block(
+ print(", value = ["),
+ print(string(ex[1])),
+ print("], dispvalue = ["),
+ print(stack_dispvalue(ex[1])),
+ print("], display = ["),
+ print(stack_disp(ex[1], "")),
+ print("]"),
+ ex:ex[1]
+ ),
+ print("], "),
+ return(ex)
+)$
+
+/* This function strips out functions to leave only things in the value which might be typed in. */
+stack_dispvalue(ex) := block(
+ if not(stack_disp_control_structurep(ex)) then block(
+ if safe_op(ex)="%union" and is(length(args(ex))=1) then
+ ex: first(args(ex)),
+ ex: make_displaydpvalue(ex),
+ ex: make_displayscivalue(ex),
+ ex: subst("*", stackunits, ex),
+ ex: unary_minus_sort(ex),
+ ex: destackvector(ex)),
+ return(string(ex))
+)$
/* ********************************** */
/* Load contributed packages */
/* ********************************** */
-load ("functs");
+load("functs");
+/* Not yet testsed: load("vect"); */
+
+/* Load the logic package, but remove the "eq" infix operator which conflicts with too many existing things. */
+/* We've edited the logic package which over writes the eq operator as xnor. */
+load("stack_logic.lisp");
/* We don't want to allow people to put boxes round things. */
box(ex) := ex;
@@ -92,66 +145,186 @@ matchfix("|", "|");
/* 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 */
/* ********************************** */
+/* This must come before stacktex.lisp as the latter relies on compiled functions in utils.mac. */
+load("utils.mac");
+load("errortostring.lisp");
+
load("assessment.mac");
+load("validator.mac");
+load("noun_simp.mac");
load("inequalities.mac");
load("intervals.mac");
load("stackunits.mac");
+load("stackstrings.mac");
+load("fboundp.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");
+if is(MAXIMA_VERSION_NUM<44.0) then load("stack44.mac");
+
+/* This file is a modified core Maxima function with local variable name clashes fixed. */
+load("trigrat.lisp");
+load("trigtools");
+load("diag");
+
+load("sregex");
+load("numericaltest.mac");
+
+load("local.mac");
+
+/* Breaks on older versions of Maxima. */
+if is(MAXIMA_VERSION_NUM>30.0) then compile(scientific_notation)$
texput(QMCHAR, "\\color{red}{?}");
texput(theta, "\\theta");
-alias(arccos, acos); /* At the request of the OU, 4 Feb 2013. */
-alias(arcsin, asin);
-alias(arctan, atan);
+int([ex]) := apply(integrate, ex); /* Allows integrate to be called with int(). Avoid alias to allow nouns to work. */
+alias(cosec,csc); /* Corresponds to current student expectations. */
+alias(cosech,csch); /* Corresponds to current student expectations. */
+
+alias(sgn,signum); /* Corresponds to current student expectations. */
+texput(signum, "\\mathrm{sgn}");
+
+declare ("#", commutative);
+
+simplify(ex) := ev(fullratsimp(ex), simp); /* Allows simplify to be something. */
+degree(ex, v) := ev(hipow(expand(ex), v), simp); /* See notes on hipow. */
-load("mathml.lisp");
make_complexJ(OPT_COMPLEXJ) := block(
if OPT_COMPLEXJ = "i" then
- (i:%i,load("complexi.lisp"))
+ (i:%i,texput(%i,"\\mathrm{i}"))
else if OPT_COMPLEXJ = "j" then
- (%j:%i,j:%i,load("complexj.lisp"))
+ (%j:%i,j:%i,texput(%i,"\\mathrm{j}"))
else if OPT_COMPLEXJ = "symi" then
- (load("complexi.lisp"))
+ (texput(%i,"\\mathrm{i}"))
else if OPT_COMPLEXJ = "symj" then
- (load("complexj.lisp"))
+ (texput(%i,"\\mathrm{j}"))
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")
+ if OPT_MULTSGN = "cross" then texput("*", "\\times ", nary),
+ if OPT_MULTSGN = "dot" then texput("*", "\\cdot ", nary),
+ if OPT_MULTSGN = "onum" then texput("*", multsgnonlyfornumbers),
+ if OPT_MULTSGN = "blank" then texput("*", "\\, ", nary)
);
-/* 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")
-);
+/* This only prints a multiplication sign for numbers. */
+/* Thanks to Evgeniy Silchenko. */
+texput(multsgnonlyfornumberssym, "\\times")$
+
+multsgnonlyfornumbers(e) := block([arglist, resstr, a, lastisnum, isnum, multsgn, str],
+ arglist: args(e),
+ a: pop(arglist),
+ resstr: if (atom(a) or is(length(args(a))=1) or safe_op(a) = "^") then tex1(a)
+ else sconcat("\\left(", tex1(a), "\\right)"),
+ lastisnum: numberp(a),
+ for a in arglist do (
+ isnum: numberp(a),
+ multsgn: if (lastisnum and isnum) then tex1(multsgnonlyfornumberssym) else "\\,",
+ str: if (atom(a) or is(length(args(a))=1) or safe_op(a) = "^") then tex1(a)
+ else sconcat("\\left(", tex1(a), "\\right)"),
+ resstr: sconcat(resstr, multsgn, " ", str),
+ lastisnum: isnum
+ ),
+ resstr
+)$
+
+make_logic(OPT_LOGIC) := block(
+ if OPT_LOGIC = "lang" then block(
+ texput("and", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("nounand", "\\,{\\mbox{ !AND! }}\\, ", nary),
+ texput("or", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nounor", "\\,{\\mbox{ !OR! }}\\, ", nary),
+ texput("nand", "\\,{\\mbox{ !NAND! }}\\, ", nary),
+ texput("nor", "\\,{\\mbox{ !NOR! }}\\, ", nary),
+ texput("xor", "\\,{\\mbox{ !XOR! }}\\, ", nary),
+ texput("xnor", "\\,{\\mbox{ !XNOR! }}\\, ", nary),
+ texput("implies", "\\,{\\mbox{ !IMPLIES! }}\\, ", nary),
+ texput("not", "{\\rm !NOT!}", prefix),
+ texput("nounnot", "{\\rm !NOT!}", prefix)
+ ),
+ if OPT_LOGIC = "symbol" then block(
+ texput("and", "\\land ", nary),
+ texput("nounand", "\\land ", nary),
+ texput("or", "\\lor ", nary),
+ texput("nounor", "\\lor ", nary),
+ texput("nand", "\\overline{\\land}", nary),
+ texput("nor", "\\underline{\\lor}", nary),
+ texput("xor", "\\oplus ", nary),
+ texput("xnor", "\\leftrightarrow ", nary),
+ texput("implies", "\\rightarrow ", nary),
+ texput("not", "\\neg ", prefix),
+ texput("nounnot", "\\neg ", prefix)
+ ),
+ return(true)
+)$
+make_arccos(OPT_ACOS) := block(
+ if OPT_ACOS = "cos-1" then block(
+ ?tex\-setup(?cdr([?%asin, "\\sin^{-1}"])),
+ ?tex\-setup(?cdr([?%acos, "\\cos^{-1}"])),
+ ?tex\-setup(?cdr([?%atan, "{\\tan^{-1}}"])),
+ ?tex\-setup(?cdr([?%asec, "{\\rm sec}^{-1}"])),
+ ?tex\-setup(?cdr([?%acsc, "{\\rm csc}^{-1}"])),
+ ?tex\-setup(?cdr([?%acot, "{\\rm cot}^{-1}"])),
+ ?tex\-setup(?cdr([?%asinh, "{\\rm sinh}^{-1}"])),
+ ?tex\-setup(?cdr([?%acosh, "{\\rm cosh}^{-1}"])),
+ ?tex\-setup(?cdr([?%atanh, "{\\rm tanh}^{-1}"])),
+ ?tex\-setup(?cdr([?%asech, "{\\rm sech}^{-1}"])),
+ ?tex\-setup(?cdr([?%acsch, "{\\rm csch}^{-1}"])),
+ ?tex\-setup(?cdr([?%acoth, "{\\rm coth}^{-1}"]))
+ ),
+ if OPT_ACOS = "arccos" then block(
+ ?tex\-setup(?cdr([?%asin, "\\arcsin "])),
+ ?tex\-setup(?cdr([?%acos, "\\arccos "])),
+ ?tex\-setup(?cdr([?%atan, "\\arctan "])),
+ ?tex\-setup(?cdr([?%asec, "{\\rm arcsec}"])),
+ ?tex\-setup(?cdr([?%acsc, "{\\rm arccsc}"])),
+ ?tex\-setup(?cdr([?%acot, "{\\rm arccot}"])),
+ ?tex\-setup(?cdr([?%asinh, "{\\rm arcsinh}"])),
+ ?tex\-setup(?cdr([?%acosh, "{\\rm arccosh}"])),
+ ?tex\-setup(?cdr([?%atanh, "{\\rm arctanh}"])),
+ ?tex\-setup(?cdr([?%asech, "{\\rm arcsech}"])),
+ ?tex\-setup(?cdr([?%acsch, "{\\rm arccsch}"])),
+ ?tex\-setup(?cdr([?%acoth, "{\\rm arccoth}"]))
+ ),
+ if OPT_ACOS = "acos" then block(
+ ?tex\-setup(?cdr([?%asin, "{\\rm asin}"])),
+ ?tex\-setup(?cdr([?%acos, "{\\rm acos}"])),
+ ?tex\-setup(?cdr([?%atan, "{\\rm atan}"])),
+ ?tex\-setup(?cdr([?%asec, "{\\rm asec}"])),
+ ?tex\-setup(?cdr([?%acsc, "{\\rm acsc}"])),
+ ?tex\-setup(?cdr([?%acot, "{\\rm acot}"])),
+ ?tex\-setup(?cdr([?%asinh, "{\\rm asinh}"])),
+ ?tex\-setup(?cdr([?%acosh, "{\\rm acosh}"])),
+ ?tex\-setup(?cdr([?%atanh, "{\\rm atanh}"])),
+ ?tex\-setup(?cdr([?%asech, "{\\rm asech}"])),
+ ?tex\-setup(?cdr([?%acsch, "{\\rm acsch}"])),
+ ?tex\-setup(?cdr([?%acoth, "{\\rm acoth}"]))
+ ),
+ if OPT_ACOS = "arccos-arcosh" then block(
+ ?tex\-setup(?cdr([?%asin, "\\arcsin "])),
+ ?tex\-setup(?cdr([?%acos, "\\arccos "])),
+ ?tex\-setup(?cdr([?%atan, "\\arctan "])),
+ ?tex\-setup(?cdr([?%asec, "{\\rm arcsec}"])),
+ ?tex\-setup(?cdr([?%acsc, "{\\rm arccsc}"])),
+ ?tex\-setup(?cdr([?%acot, "{\\rm arccot}"])),
+ ?tex\-setup(?cdr([?%asinh, "{\\rm arsinh}"])),
+ ?tex\-setup(?cdr([?%acosh, "{\\rm arcosh}"])),
+ ?tex\-setup(?cdr([?%atanh, "{\\rm artanh}"])),
+ ?tex\-setup(?cdr([?%asech, "{\\rm arsech}"])),
+ ?tex\-setup(?cdr([?%acsch, "{\\rm arcsch}"])),
+ ?tex\-setup(?cdr([?%acoth, "{\\rm arcoth}"]))
+ )
+)$
/* Fine tune the display of fractions between inline and displayed. */
stackfractionsinline(e) := block ([a, b],
@@ -178,6 +351,17 @@ stack_disp_fractions(ex) := block(
nary("blankmult", 0, 0);
texput("blankmult", " ", nary);
+/* ****************************************************** */
+/* Unit testing of questions */
+/* ****************************************************** */
+/* This function allows a teacher to add unit tests to */
+/* individual questions. At the end of the question */
+/* variables, or in the feedback variables, particular */
+/* values can throw runtime errors. */
+/* ****************************************************** */
+s_assert(ex1, ex2):= if is(ex1=ex2) then true else
+ error("s_assert: STACK expected '", string(ex2), "' but was given '", string(ex1), "'.");
+
/* ****************************************************** */
/* Random numbers */
/* ****************************************************** */
@@ -194,6 +378,7 @@ stack_randseed(s) := block(RANDOM_STATE:make_random_state(s), errcatch(ev(set_ra
/* The top level function */
rand(ex) := block(
+ if setp(ex) then ex:listify(ex),
ex:ev(ex, simp),
if (integerp(ex)) then return(random(ex)),
if (floatnump(ex)) then return(random(ex)),
@@ -201,6 +386,14 @@ rand(ex) := block(
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([])
)$
@@ -223,19 +416,42 @@ rand_with_prohib(lower, upper, list) := block([currents, retVal, kloop],
return(retVal)
)$
-/* Make a random selection of n different items from the list ex. */
+/* CJS, 11/6/2021 */
+rand_selection_with_replacement(ex, n) := block(
+ if setp(ex) then ex:listify(ex),
+ if not(listp(ex)) then (
+ error("rand_selection_with_replacement error: first argument must be a list."),
+ return([])
+ ),
+ if not(integerp(n)) then (
+ error("rand_selection_with_replacement error: second argument must be an integer."),
+ return([])
+ ),
+ return(rand_selection_with_replacement_fun(ex, n))
+)$
+
+/* We can't use makelist here because of the simp:false requirement.
+rand_selection_with_replacement_fun(ex, n) := makelist(rand(ex), k, 1, n)$
+*/
+rand_selection_with_replacement_fun(ex, n) := block(
+ if is(n<=0) then return([]),
+ append([rand(ex)], rand_selection_with_replacement_fun(ex, ev(n-1,simp)))
+)$
+
+/* Make a random selection of n different items from the list, or set ex. */
/* CJS, 7/6/2016 */
rand_selection(ex, n) := block(
+ if setp(ex) then ex:listify(ex),
if not(listp(ex)) then (
- print("rand_selection error: first argument must be a list."),
+ error("rand_selection error: first argument must be a list or set."),
return([])
),
if not(integerp(n)) then (
- print("rand_selection error: second argument must be an integer."),
+ error("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."),
+ error("rand_selection error: insuffient elements in the list/set."),
return([])
),
return(rand_selection_fun(ex, n))
@@ -255,22 +471,37 @@ list_remove(ex, n) := block([k, l],
makelist(ex[k], k, l)
)$
+/********************************************/
+/*********** Random set generation *********/
+/********************************************/
+/* Could be implemented with rand_selection but would require two conversions
+ * between sets and lists*/
+random_subset(u):=
+ disjoin(false, map(lambda([x], if rand(2)=0 then x), u));
+
+random_subset_n(u,n) :=
+ setify(rand_selection(listify(u),n));
+
+/* random non-empty subset */
+random_ne_subset(u) := random_subset_n(u, rand(cardinality(u))+1);
+
+
/* Create a number in a random range. */
rand_range([ex]) := block(
- if (length(ex)<2 or length(ex)>3) then error("rand_range must have 2 or three arguments."),
+ 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(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))
-);
+ 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: forth 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)),
@@ -280,12 +511,39 @@ multiselqn(corbase, numcor, wrongbase, numwrong):=block([ta1, ta2, ta, version],
return([ta, version])
)$
+/* Helper function for constructing MCQ arrays with auto-generated alphabetic labels. Students choose the labels. */
+multiselqnalpha([exs]):=block([corbase, numcor, wrongbase, numwrong, dispflag, ta1, ta2, ta3, talab, ta, version],
+ if length(exs)<4 then error("multiselqnalpha must have at least four arguments."),
+ corbase:first(exs),
+ numcor:second(exs),
+ wrongbase:third(exs),
+ numwrong:fourth(exs),
+ dispflag:"id",
+ if length(exs)>4 then dispflag:fifth(exs),
+ if not(listp(corbase)) then error("multiselqnalpha: first argument must be a list."),
+ if not(listp(wrongbase)) then error("multiselqnalpha: third argument must be a list."),
+ if not(integerp(numcor)) then error("multiselqnalpha: second argument must be an integer."),
+ if not(integerp(numwrong)) then error("multiselqnalpha: fourth argument must be an integer."),
+ if length(corbase)<numcor then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+ if length(wrongbase)<numwrong then error("multiselqnalpha: you have asked for more correct responses than are supplied in the list!"),
+
+ ta1: maplist(lambda([ex], [ex, true]), rand_selection(corbase, numcor)),
+ ta2: maplist(lambda([ex], [ex, false]), rand_selection(wrongbase, numwrong)),
+ ta3: random_permutation(append(ta1, ta2)),
+ /* Add in a slightly different display here. */
+ talab: ev(makelist(sconcat("(",ascii(96+i),")"), i, 1, length(ta3)), simp),
+ ta:zip_with(lambda([ex1, ex2], [ex1, ex2[2], sconcat("<b>", ex1, "</b> ",
+ if stringp(ex2[1]) then ex2[1] else stack_disp(ex2[1], dispflag))]), talab, ta3),
+ version: map(first, ta3),
+ return([ta, version])
+)$
+
/* Helper function for constructing MCQ arrays where the values should not be shown to students. */
multiselqndisplay(corbase, numcor, wrongbase, numwrong):=block([ta1, ta2, ta, version],
if not(listp(corbase)) then error("multiselqndisplay: first argument must be a list."),
if not(listp(wrongbase)) then error("multiselqndisplay: third argument must be a list."),
if not(integerp(numcor)) then error("multiselqndisplay: second argument must be an integer."),
- if not(integerp(numwrong)) then error("multiselqndisplay: forth 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!"),
/* */
@@ -314,6 +572,122 @@ mcq_incorrect(ta):=block(
maplist(first, sublist(ta, lambda([ex], not(second(ex)))))
)$
+/* ********************************** */
+/* Statistics function */
+/* ********************************** */
+
+/* ------------------ Mode function --------------------- */
+/* mode(n) returns a list of all the modal elements in the list n */
+mode(n):= block([i,j,count_elements,counts,highest_count,mode_set],
+ count_elements: makelist(0,i,1,length(n)),
+ for i: 1 thru length(n) do
+ (for j: 1 thru length(n) do
+ (if n[i]=n[j] then count_elements[i]: count_elements[i]+1)),
+ counts: listify(setify(count_elements)),
+ highest_count:counts[length(counts)],
+ mode_set:{},
+ for i:1 thru length(n) do
+ (if count_elements[i]=highest_count then mode_set: union(mode_set,{n[i]})),
+ mode_list:listify(mode_set),
+ return(mode_list)
+)$
+
+/* ********************************** */
+/* cassession2 I/O management */
+/* ********************************** */
+
+/* Current statement identifier */
+%stmt: "0"$
+
+/* Collected errors */
+%ERR: ["stack_map"]$
+
+/* Collected notes */
+%NOTES: ["stack_map"]$
+
+/* Collected feedback */
+%FEEDBACK: ["stack_map"]$
+
+/* Function to declare errors from within logic. */
+/* With reference to position in logic. */
+_APPEND_ERR(err_list, reference) := if ev(stackmap_has_key(%ERR, %stmt), simp)
+ then
+ %ERR:stackmap_set(%ERR, %stmt, append(stackmap_get(%ERR,%stmt),[[err_list,reference]]))
+ else
+ %ERR:stackmap_set(%ERR, %stmt, [[err_list,reference]])$
+
+_UNDO_ERR(err_list, reference) := block([%_tmp],
+ if (ev(stackmap_has_key(%ERR, %stmt), simp)) then (
+ %_tmp: stackmap_get(%ERR,%stmt),
+ %_tmp: delete([err_list,reference], %_tmp),
+ %ERR: stackmap_set(%ERR, %stmt, %_tmp)
+ )
+)$
+
+/* Function to attach a note to the current statement. */
+_APPEND_NOTE(note) := if ev(stackmap_has_key(%NOTES, %stmt), simp)
+ then
+ %NOTES:stackmap_set(%NOTES,%stmt,append(stackmap_get(%NOTES,%stmt),[note]))
+ else
+ %NOTES:stackmap_set(%NOTES,%stmt,[note])$
+
+_RESET_NOTES() := %NOTES:stackmap_unset(%NOTES,%stmt)$
+
+/* Function to attach a note to the current statement. */
+_APPEND_FEEDBACK(feedback) := if ev(stackmap_has_key(%FEEDBACK, %stmt), simp)
+ then
+ %FEEDBACK:stackmap_set(%FEEDBACK,%stmt,append(stackmap_get(%FEEDBACK,%stmt),[feedback]))
+ else
+ %FEEDBACK:stackmap_set(%FEEDBACK,%stmt,[feedback])$
+
+/* Reset any feedback. */
+_RESET_FEEDBACK() := %FEEDBACK:stackmap_unset(%FEEDBACK,%stmt)$
+
+/* General error catching wrapper */
+_EC(errcatched, reference) := if errcatched = []
+ then
+ (_APPEND_ERR([errormsgtostring()], reference), false)
+ else
+ true$
+
+/* Shorthand for allowing even more to fit into the buffer. */
+/* Note that stackmap_set is not very performance optimised and
+ as the CS2 context newer redefines values we can just append.
+ If we were to use the set functionality we meet trouble at around
+ 250 keys. */
+/* Catch to %_tmp before placement to list to check if the value is
+ a list just in case there is an error of some sort, if it is not
+ a list then that append would do bad things. */
+_CS2v(_k,_v) := block([%_tmp],
+ %_tmp:[[_k, string(_v)]],
+ if listp(%_tmp) then _VALUES:append(_VALUES,%_tmp),
+ 0)$
+_CS2l(_k,_v) := block([%_tmp],
+ %_tmp:[[_k, stack_disp(_v, "")]],
+ if listp(%_tmp) then _LATEX:append(_LATEX,%_tmp),
+ 0)$
+_CS2dv(_k,_v) := block([%_tmp, simp],
+ /* We don't want to simplify products with zero to zero here. */
+ simp:false,
+ %_tmp:[[_k, stack_dispvalue(_v)]],
+ if listp(%_tmp) then _DVALUES:append(_DVALUES,%_tmp),
+ 0)$
+_CS2dvv(_k,_v) := (_CS2v(_k,_v),_CS2dv(_k,_v),0)$
+
+_CS2out() := (
+ _RESPONSE : stackmap_set(_RESPONSE, "timeout", false),
+ _RESPONSE : stackmap_set(_RESPONSE, "values", _VALUES),
+ if length(%ERR) > 1 then
+ _RESPONSE : stackmap_set(_RESPONSE, "errors", %ERR),
+ if length(%NOTES) > 1 then
+ _RESPONSE : stackmap_set(_RESPONSE, "notes", %NOTES),
+ if length(%FEEDBACK) > 1 then
+ _RESPONSE : stackmap_set(_RESPONSE, "feedback", %FEEDBACK),
+ print("STACK-OUTPUT-BEGINS>"),
+ print(stackjson_stringify(_RESPONSE)),
+ print("<STACK-OUTPUT-ENDS")
+)$
+
/* ********************************** */
/* Display */
/* ********************************** */
@@ -327,24 +701,26 @@ mcq_incorrect(ta):=block(
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)),
+ if not(ev(elementp(exprm, {"", "i", "d", "id", "i{", "{"}), simp)) then print(concat("ERROR: illegal delimiter option found: ", exprm)),
/* Fine tune display, e.g. sort out display of atoms like theta0. */
- expru: expr,
+ expru: %_ce_rem(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],
+ str: block([expstr, ld, rd],
ld: "",
rd: "",
if exprm = "i" then block(ld: "\\(", rd:"\\)"),
+ if exprm = "i{" then block(ld: "\\({", rd:"}\\)"),
+ if exprm = "{" 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)
),
- /* 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. */
@@ -372,26 +748,37 @@ stack_disp_strip_dollars(ex) := block(
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
+ 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 */
-/* ********************************** */
+/* **************************************************** */
+/* 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)))),
- 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)
+ if taylorp(ex) then return(ex),
+ if safe_setp(ex) then return(apply(set, maplist(stack_disp_sub_script, args(ex)))),
+ if arrayp(ex) then return(arraymake(op(ex), maplist(stack_disp_sub_script, args(ex)))),
+ /* The following are not, strictly speaking, a subscript issue, but we don't want another recursive call. */
+ /* Strip out empty plus operators, which cause problems in display with simp:false. */
+ if is(safe_op(ex)="+") and is(length(args(ex))=1) then return(stack_disp_sub_script(first(args(ex)))),
+ /* Now deal with supscripts. */
+ if not(atom(ex)) then return(apply(op(ex), maplist(stack_disp_sub_script, args(ex)))),
+ if simp_numberp(ex) or stringp(ex) or ex or not(ex) then return(ex),
+ /* Check for an explicit entry in the texput database for this atom. */
+ if stringp(get_texword(ex)) then return(ex),
+ s: string(ex),
+ s: split(s, "_"),
+ /* If we can't parse the string back, just use the string. */
+ s: maplist(lambda([ex], block([parsed], parsed:errcatch(parse_string(ex)), if emptyp(parsed) then ex else first(parsed))), s),
+ stack_disp_sub_script_helper(s)
)$
stack_disp_sub_script_helper(l) := block(
@@ -399,6 +786,18 @@ stack_disp_sub_script_helper(l) := block(
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 */
/* ********************************** */
@@ -424,22 +823,6 @@ detexcolor(ex) := block([argsex],
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
@@ -448,10 +831,10 @@ texboldatoms(ex) := block(
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("")),
+ 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 (print(concat("\\mbox{ERROR: stack_matrix_disp cannot display matrices with parentheses ", string(lmxchar), "}")), return("")),
+ 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),
@@ -536,49 +919,11 @@ unary_minus_pull_helper(ex) := block([fe],
/* 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),
+ 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),
- ex: opsubst("*", stackunits, ex),
- return(string(ex))
-)$
-
/* ********************************** */
/* Generate feedback */
/* ********************************** */
@@ -591,175 +936,23 @@ StackAddFeedback(fb, key, [ex]) := block([str, exprs, jloop],
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)
+ 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) := concat(exnote, newnote, ". ")$
+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)]$
-/* ********************************************************* */
-/* 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, */
/* *************************************/
@@ -771,7 +964,10 @@ 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],
+ block([simp:true, tfn, tfnp1, tfnp2, tfnp3, afn, ufn, lvs, preamble, sysp, sysr,
+ filename, tn, alt, altc, alttext, ral, ralforbid, pltargs, plotfunmake, plotdebug,
+ plotgrid2d, size, psize, plot_size, plot_tags, stack_mtell_quiet, plotpid],
+ stack_mtell_quiet:true,
plotdebug: false,
/* Check for grid2d in the plotoptions. */
plotgrid2d: false,
@@ -782,20 +978,19 @@ plot(ex, [ra]) := /*stack_web_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),
+ if not(freeof(lg, ex)) then
+ ex:ev(ex, lg=logbasesimp),
+ lvs: listofvars(%_ce_rem(ex)),
lvs: sublist(lvs, lambda([ex], not(ex = discrete or ex = parametric))),
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>")),
+ 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 (alttext:"ERROR", print("Plot error: the alt tag definition must be a string, but is not."), return("")),
+ 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),
@@ -803,7 +998,7 @@ plot(ex, [ra]) := /*stack_web_plot*/
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
+ 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])),
/*******************/
@@ -816,27 +1011,27 @@ plot(ex, [ra]) := /*stack_web_plot*/
/**********************************************************/
/* 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],
+ permitted_options: [y, xlabel, ylabel, label, legend, color, style, point_type, nticks, logx, logy, axes, box, plot_realpart, yx_ratio, xtics, ytics, ztics, adapt_depth],
/* 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>")),
+ error("Plot error: STACK does not currently support the following plot2d options: \\(",string(ralforbid),"\\)"),
/********************************************/
/* Create a unique identifier for the plot. */
+ plotpid:errcatch(?getpid()),
+ if (emptyp(plotpid) or not(integerp(first(plotpid)))) then plotpid:"pid-missing" else plotpid:string(first(plotpid)),
tn: string(absolute_real_time()),
- filename:concat("stackplot","-",tn,"-",string(rand(10^8))),
+ STACK_PLOT_UNIQUE_NUMBER:STACK_PLOT_UNIQUE_NUMBER + 1,
+ filename:concat("stackplot", "-", plotpid, "-", string(STACK_PLOT_UNIQUE_NUMBER), "-", tn,"-",string(rand(10^8))),
/* Sort out the name of the image file and its url. */
afn: concat("'", IMAGE_DIR, filename, ".", PLOT_TERMINAL, "'"),
if PLOT_TERMINAL="svg" then
afn: concat(IMAGE_DIR, filename, ".", PLOT_TERMINAL),
- ufn: concat("<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> "),
+ 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>"),
/* Sort out plot_options and preamble*/
preamble: "",
if not(member(xlabel, maplist(first, ral))) then ral: append(ral, [[xlabel, ""]]),
@@ -851,16 +1046,15 @@ plot(ex, [ra]) := /*stack_web_plot*/
/* 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
+ if PLOT_TERMINAL="svg" then
set_plot_option([gnuplot_svg_term_command, preamble])
- else
+ else
set_plot_option([gnuplot_preamble, preamble]),
/* Sort out the name and location of temporary Gnuplot files. */
tfn:concat(filename, ".plt"),
@@ -880,6 +1074,7 @@ set output ", afn),
set_plot_option([gnuplot_out_file, tfnp1]),
if plotdebug then print(plot_options),
/* Create and execute the actual plot commands. */
+ ex:%_ce_expedite(ex),
pltargs: append([ex], ral),
if plotdebug then print(pltargs),
plotfunmake: funmake(plot2d, pltargs),
@@ -893,236 +1088,58 @@ set output ", afn),
return(ufn)
)$
+
/* ********************************** */
-/* Numerical operations */
+/* Algebraic tests */
/* ********************************** */
-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"),
+/* A general, all purpose answer test based maximum simplification.
+ This function is a wrapper for AtAlgEquivfun(SA,SB)
+*/
+ATAlgEquiv(SA,SB) := block([simp:true, ret, newret, SAN, SBN],
/* Turn on simplification and error catch */
- 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")
- )
+ if is(_EC(errcatch(SA:ev(stack_noteq_single_solve(SA), simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_SAns"), ""]),
+ /* We need a copy here because lists are passed by reference and the colouring of incorrect entries
+ causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */
+ SAN:copy(SA),
+ if is(_EC(errcatch(SB:ev(stack_noteq_single_solve(SB), simp, nouns, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquiv_STACKERROR_TAns"),""]),
+ /* Start recursive process */
+ SBN:copy(SB),
+ /* Start recursive process */
+ ret:ATAlgEquivfun(SAN, SBN),
+ /* Can we find a permutation of the variables? */
+ if ret[2]=0 then block([p1],
+ /* Start with a clean copy of SA to remove any texcolor. */
+ SAN:copy(SA),
+ p1:subst_equiv(SAN, SB, []),
+ /* Actually, at this point 2008/7/7, we don't want to give this feedback. Just leave an answer note. */
+ /* if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), StackAddFeedback(ret[4], "Subst", stack_disp(p1, "d"))] */
+ if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), ret[4]]
),
- 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)
+/* An algebraic equivalence test which does not evaluate noun forms, but does other simplifications.
*/
-ATAlgEquiv(SA,SB) := block([simp:true, ret, newret, SAN],
+ATAlgEquivNouns(SA,SB) := block([simp:true, ret, newret, SAN, SBN],
/* 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],
+ if is(_EC(errcatch(SA:ev(SA, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_SAns"), ""]),
+ /* We need a copy here because lists are passed by reference and the coloring of incorrect entries
+ causes problems when the values are used later in a PRT. This problem did not occur with single call answer tests. */
+ SAN:copy(SA),
+ if is(_EC(errcatch(SB:ev(SB, simp, rat)), "") = false) then
+ return([false, false, StackAddNote("", "ATAlgEquivNouns_STACKERROR_TAns"),""]),
+ SBN:copy(SB),
/* Start recursive process */
- ret:ATAlgEquivfun(SA, SB),
+ ret:ATAlgEquivfun(SAN, SBN),
/* Can we find a permutation of the variables? */
if ret[2]=0 then block([p1],
- p1:subst_equiv(SAN, SB),
+ /* Start with a clean copy of SA to remove any texcolor. */
+ SAN:copy(SA),
+ p1:subst_equiv(SAN, SBN),
/* Actually, at this point 2008/7/7, we don't want to give this feedback. Just leave an answer note. */
/* if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), StackAddFeedback(ret[4], "Subst", stack_disp(p1, "d"))] */
if p1#[] and p1#false then ret:[ret[1], ret[2], StackAddNote(ret[3], concat("ATAlgEquiv_Subst ", string(p1))), ret[4]]
@@ -1130,8 +1147,8 @@ ATAlgEquiv(SA,SB) := block([simp:true, ret, newret, SAN],
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.
+/* 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
@@ -1139,7 +1156,7 @@ ATAlgEquiv(SA,SB) := block([simp:true, ret, newret, SAN],
AnswerNote = "string",
FeedBack = StackFeedback
*/
-ATAlgEquivfun(SA, SB) := block([keepfloat, RawMark, FeedBack, AnswerNote, ret],
+ATAlgEquivfun(SA, SB) := block([SApoly, SBpoly, keepfloat, RawMark, FeedBack, AnswerNote, ret],
Validity:true, RawMark:false, FeedBack:"", AnswerNote:"",
keepfloat:true,
/* Are we dealing with strings? */
@@ -1166,25 +1183,34 @@ ATAlgEquivfun(SA, SB) := block([keepfloat, RawMark, FeedBack, AnswerNote, ret],
return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_set"))
else
return(ATSet(SA, SB)),
+ /* Are we dealing with non-trivial sets? */
+ if realset_soft_p(SB) and not(trivialintervalp(SB)) then
+ if not(realset_soft_p(SA)) then
+ return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_realset")),
+ /* No specific function here, as "all" and "none" can show up with equations. */
/* Are we dealing with a function? */
if functionp(SB) then
if functionp(SA)#true then
return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_function"))
else
return(ATFunction(SA, SB)),
- /* Are we dealing with 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
+ /* 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, "+-"))) then return(StackBasicReturn(false, false, "ATAlgEquiv_TA_not_equation")),
+ 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) then
- if inequalityp(SA)#true and logicp(SA)#true then
+ 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)),
@@ -1193,18 +1219,48 @@ ATAlgEquivfun(SA, SB) := block([keepfloat, RawMark, FeedBack, AnswerNote, ret],
return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_logic"))
else
return(ATLogic(SA, SB)),
+ if realset_soft_p(SA) and realset_soft_p(SB) then
+ return(ATRealSet(SA, SB)),
/* Has the student typed in the wrong type?*/
if expressionp(SA)=false then
return(StackBasicReturn(false, false, "ATAlgEquiv_SA_not_expression")),
/* Otherwise we have two expressions*/
- if algebraic_equivalence(SA, SB) then
+ if SA=SB then
+ RawMark:true
+ else if algebraic_equivalence(SA, SB) then
RawMark:true
- else if algebraic_equivalence(exdowncase(SA), exdowncase(SB)) then
- AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase"),
+ else block([SAd, SBd, exeq],
+ /* algebraic_equivalence is not free, so only execute this when we need to do so. */
+ SAd:exdowncase(SA),
+ SBd:exdowncase(SB),
+ /* If lower case variables are defined then this can throw an error here. E.g. SA:1/B, but b:0 elsewhere.... */
+ exeq:errcatch(algebraic_equivalence(SAd, SBd)),
+ if is(exeq = []) then print("STACK: ignore previous error. (WrongCase)") else
+ if (SAd#SA or SBd#SB) and first(exeq) then
+ AnswerNote:StackAddNote("", "ATAlgEquiv_WrongCase")
+ ),
ret:[Validity, RawMark, AnswerNote, FeedBack],
return(ret)
)$
+stack_noteq_single_solve(ex) := block(
+ if atom(ex) then return(ex),
+ if freeof("#", ex) then return(ex),
+ if not(safe_op(ex)="#") then return(apply(op(ex), map(stack_noteq_single_solve, args(ex)))),
+ /* Only attempt solving in single variables cases. */
+ if length(listofvars(ex))=1 then return(apply("nounand", map(lambda([ex2], subst("#","=",ex2)), solve(first(ex)=second(ex))))),
+ ex
+)$
+
+stack_noteq_single_remove(ex) := block(
+ if atom(ex) then return(ex),
+ if freeof("#", ex) then return(ex),
+ if not(safe_op(ex)="#") then return(apply(op(ex), map(stack_noteq_single_remove, args(ex)))),
+ /* Only attempt solving in single variables cases. */
+ if length(listofvars(ex))=1 then return((first(ex)<second(ex) nounor first(ex)>second(ex))),
+ ex
+)$
+
/* An answer test based on two lists for SA and SB */
ATList(SA,SB) := block([AddFeedBack, SAN, SAl, SBl, ret, retnew, kloop, AnsNotes],
/* Get sizes of lists */
@@ -1243,6 +1299,17 @@ ATList(SA,SB) := block([AddFeedBack, SAN, SAl, SBl, ret, retnew, kloop, AnsNotes
return(ret)
)$
+/* An answer test based on two sets of real numbers. */
+ATRealSet(SA, SB) := block(
+ /* Tidy up intervals as much as possible. Some tidying might be possible even with realset_soft_p rather than realsets.*/
+ SA:interval_tidy(SA),
+ SB:interval_tidy(SB),
+
+ if is(SA=SB) then
+ return([true, true, StackAddNote("", "ATRealSet_true"), ""]),
+ return([true, false, StackAddNote("", "ATRealSet_false"), ""])
+)$
+
/* Equations */
/* Note, this uses expand, which will break large expressions. */
stack_eqnprepare(ex) := block([ret, keepfloat],
@@ -1301,6 +1368,10 @@ ATEquation(SA, SB) := block([keepfloat, RawMark, SA1, SB1, SB2, Rationalex1, Rat
if algebraic_equivalence(lhs(SA), rhs(SA)) then SA:all,
if algebraic_equivalence(lhs(SB), rhs(SB)) then SB:all,
+ /* If we have one side is zero, then make sure it is the rhs. */
+ if algebraic_equivalence(lhs(SA),0) then SA:rhs(SA)=0,
+ if algebraic_equivalence(lhs(SB),0) then SB:rhs(SB)=0,
+
/* Trap edge cases. */
edgecase:false,
if logic_edgep(SA) or logic_edgep(SB) then edgecase:true,
@@ -1316,7 +1387,6 @@ ATEquation(SA, SB) := block([keepfloat, RawMark, SA1, SB1, SB2, Rationalex1, Rat
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),
@@ -1400,6 +1470,7 @@ ATInequality(SA, SB) := block([RawMark, FeedBack, AnswerNote, SA1, SB1, samex],
),
/* Now try to give some basic feedback: potential for more work to recurse over complex expressions... */
if safe_op(SA) = ">" and safe_op(SB) =">=" then block(
+ RawMark:false,
AnswerNote:StackAddNote("", "ATInequality_strict"),
FeedBack:StackAddFeedback("", "ATInequality_strict")
),
@@ -1424,8 +1495,15 @@ ATFunction(SA, SB) := block([RawMark, FeedBack, AnswerNote, df, SA1, SB1, SAd1,
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),
+ /* 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"),
@@ -1459,12 +1537,10 @@ ATMatrix(SA, SB) := block([RawMark, FeedBack, AnswerNote, str, ret, SAr, SAc, SB
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]),
+ 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"), FeedBack]),
- FeedBack:"",
+ 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,
@@ -1484,28 +1560,303 @@ ATMatrix(SA, SB) := block([RawMark, FeedBack, AnswerNote, str, ret, SAr, SAc, SB
)$
/* An answer test based on two sets for SA and SB. */
-ATSet(SA, SB) := block([RawMark, FeedBack, AnswerNote, str, SAl, SBl, ZM],
+ATSet(SA, SB) := block([RawMark, FeedBack, AnswerNote, 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")),
+ /* Get sizes of sets. */
+ SAl:ev(cardinality(SA), simp),
+ SBl:ev(cardinality(SB), simp),
if (SAl#SBl) then
- return([true, false, StackAddNote("", "ATSet_wrongsz"), FeedBack]),
- FeedBack:"",
+ 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)),
+
+ SA:ATSets_prepare(SA),
+ SB:ATSets_prepare(SB),
+
if (subsetp(SA, SB) and subsetp(SB, SA)) then
return([true, true, AnswerNote, FeedBack]),
- /* Can we give feedback on which are wrong */
- FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(setdifference(SA, SB), "d")),
+ /* Can we give feedback on which are wrong ? */
+ ZM:setdifference(SA, SB),
+ if not(emptyp(ZM)) then
+ FeedBack:StackAddFeedback("", "ATSet_wrongentries", stack_disp(ZM, "d")),
return([true, false, StackAddNote("","ATSet_wrongentries"), FeedBack])
)$
-/* A wrapper for an all purpose answer test which checks things are of the
- same "type". Based upon the results of AtAlgEquivfun(SA,SB)
+/* Note, this test (ATSets not ATSet as above) gives much more detailed feedback
+ than the Algebraic equivalence test.
*/
+ATSets(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Turn on simplification and error catch */
+ if (is(_EC(errcatch(SAsimp:ev(SA, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATSets_STACKERROR_SAns"), ""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATSets_STACKERROR_TAns"), ""]),
+ if not(safe_setp(SB)) then
+ return(StackBasicReturn(false, false, "ATSets_SB_not_set")),
+ if not(safe_setp(SA)) then
+ return(StackBasicReturn(false, false, "ATSets_SA_not_set")),
+
+ SAsimp:ATSets_prepare(SAsimp),
+ SBsimp:ATSets_prepare(SBsimp),
+
+ /* Look for duplicate entries. */
+ if is(length(SAsimp)<length(SA)) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_duplicates"),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_duplicates")
+ ),
+
+ /* We check the simplified sets. */
+ if (subsetp(SAsimp, SBsimp) and subsetp(SBsimp, SAsimp)) then
+ return([true, true, AnswerNote, FeedBack]),
+
+ /* Can we give feedback on which are wrong ? */
+ if not(emptyp(setdifference(SAsimp, SBsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_wrongentries", stack_disp(setdifference(SAsimp, SBsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_wrongentries")
+ ),
+ if not(emptyp(setdifference(SBsimp, SAsimp))) then block(
+ FeedBack:StackAddFeedback(FeedBack, "ATSets_missingentries", stack_disp(setdifference(SBsimp, SAsimp), "d")),
+ AnswerNote:StackAddNote(AnswerNote, "ATSets_missingentries")
+ ),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+/* We don't put in boolean_form, or noun_logic_remove here because that breaks (pre-existing) inequalities and equations. */
+ATSets_prepare(S) := ev(map(lambda([ex], ineqprepare(trigreduce(ex)) ), S), simp)$
+
+
+/* Maxima regular expressions. */
+ATSRegExp(SA, SB) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, patmatched],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Turn on simplification and error catch. */
+ if (is(_EC(errcatch(SAsimp:ev(SA, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATSRegExp_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATSRegExp_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATSRegExp_SA_not_string")),
+
+ patmatched:regex_match(SBsimp, SAsimp),
+
+ if listp(patmatched) then
+ return([true, true, StackAddNote("", sconcat("ATSRegExp: ", string(patmatched))), FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+
+/* Don't break existing questions. */
+ATRegExp(SA, SB) := ATString(SA, SB);
+
+ATString(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("","ATString_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATString_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATString_SA_not_string")),
+
+ if SA=SB then
+ return([true, true, AnswerNote, FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+ATStringSloppy(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("","ATString_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]),
+ if not(stringp(SB)) then
+ return(StackBasicReturn(false, false, "ATString_SB_not_string")),
+ if not(stringp(SA)) then
+ return(StackBasicReturn(false, false, "ATString_SA_not_string")),
+
+ SA:sdowncase(SA),
+ SA:sremove(" ", SA),
+ SA:sremove(newline, SA),
+ SA:sremove(tab, SA),
+ SB:sdowncase(SB),
+ SB:sremove(" ", SB),
+ SB:sremove(newline, SB),
+ SB:sremove(tab, SB),
+
+ if SA=SB then
+ return([true, true, AnswerNote, FeedBack]),
+
+ return([true, false, AnswerNote, FeedBack])
+)$
+
+/* ********************************** */
+/* Levenshtein distance */
+/* ********************************** */
+
+/*
+ levenshtein
+ s,t: strings to compare
+ Returns integer d, the Levensthein distance between s and t.
+ author Achim Eichhorn Achim.Eichhorn(at)hs-esslingen.de
+*/
+levenshtein(s, t) := block([m, n, XY, i, j, d, temp],
+ if(s=t) then return(0.0), /* Equal strings result in 0, nothing to do. */
+ m:slength(s),
+ n:slength(t),
+ XY: matrix(makelist(i,i,0,n), makelist(0,i,1,n+1)),
+ for i:1 thru m do (
+ XY[2][1]:i,
+ for j:1 thru n do(
+ c:if(cequal(charat(s,i), charat(t,j))) then 0 else 1,
+ XY[2][j+1]:min(XY[2][j]+1, XY[1][j+1]+1, XY[1][j]+c)
+ ),
+ /* swap */
+ XY:rowswap(XY, 1, 2)
+ ),
+ d:XY[1][n+1],
+ return(d)
+)$
+
+/*
+ levenshtein_plv: weights the levenshtein distance between 0 (unequal) and 1 (equal).
+ s,t: strings to compare
+ Returns the weighted Levensthein distance of s and t.
+ author Achim Eichhorn Achim.Eichhorn(at)hs-esslingen.de
+*/
+levenshtein_plv(s, t) := 1.0-levenshtein(s, t)/max(slength(s), slength(t))$
+
+/*
+ levenshtein_compare_strings
+ needle: user input
+ haystack: list of possible answers.
+ returns list, list[1]=score, list[2]=index of which string of haystack was the best match.
+ author Achim Eichhorn Achim.Eichhorn(at)hs-esslingen.de
+*/
+levenshtein_compare_strings(needle, haystack):=block([maxscore, index, i, score],
+ maxscore:0.0,
+ index:1,
+ for i:1 thru length(haystack) do(
+ score:levenshtein_plv(needle, haystack[i]),
+ if(score >= maxscore) then block (maxscore:score, index:i)
+ ),
+ return([decimalplaces(maxscore, 5), index])
+)$
+
+ATLevenshtein(SA, SB, SO) := block([RawMark, FeedBack, AnswerNote, SAsimp, SBsimp, SBsimpmod, SOsimp, tol,
+ levupper, levwhitespace, allowf, denyf],
+ RawMark:true, FeedBack:"", AnswerNote:"",
+ /* Turn on simplification and error catch. */
+ if (is(_EC(errcatch(SAsimp:ev(SA, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATString_STACKERROR_SAns"),""]),
+ if (is(_EC(errcatch(SBsimp:ev(SB, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]),
+ if (is(_EC(errcatch(SOsimp:ev(SO, simp, nouns)), "") = false)) then
+ return([false,false,StackAddNote("","ATString_STACKERROR_TAns"),""]),
+
+ if not(stringp(SAsimp)) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_SA_not_string")),
+ /* The teacher's answer must be the [allow,deny] lists of strings. */
+ if not(listp(SBsimp)) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")),
+ if not(is(length(SBsimp)=2)) or not(listp(first(SBsimp))) or not(listp(second(SBsimp))) or not(all_listp(stringp, flatten(SBsimp))) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")),
+ if emptyp(first(SBsimp)) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_SB_malformed")),
+
+ /* Sort out options. */
+ tol:SOsimp,
+ levupper:true,
+ levwhitespace:true,
+ if listp(SOsimp) then block(
+ tol:first(SOsimp),
+ SOsimp:setify(rest(SOsimp)),
+ if elementp(CASE, SOsimp) then levupper:false,
+ if elementp(WHITESPACE, SOsimp) then levwhitespace:false
+ ),
+
+ if not(numberp(tol)) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_tol_not_number")),
+ if not(booleanp(levupper)) then
+ return(StackBasicReturn(false, false, "ATLevenshtein_upper_not_boolean")),
+
+ SBsimpmod:SBsimp,
+ /* Pre-process strings to upper case. */
+ if (levupper=true) then block(
+ SAsimp:supcase(SAsimp),
+ SBsimpmod:maplist(lambda([ex2], maplist(supcase, ex2)), SBsimpmod)
+ ),
+ /* Tidy whitespace. */
+ if (levwhitespace=true) then block(
+ SAsimp:ssquish(SAsimp),
+ SBsimpmod:maplist(lambda([ex2], maplist(ssquish, ex2)), SBsimpmod)
+ ),
+
+ /* Find the closest allow string. */
+ allowf:levenshtein_compare_strings(SAsimp, first(SBsimpmod)),
+ allowf:[first(allowf), SBsimp[1][second(allowf)]],
+ /* Find the closest deny string. */
+ denyf:[0, []],
+ if not(emptyp(second(SBsimp))) then block(
+ denyf:levenshtein_compare_strings(SAsimp, second(SBsimpmod)),
+ denyf:[first(denyf), SBsimp[2][second(denyf)]]
+ ),
+
+ if debug then print(allowf),
+ if debug then print(denyf),
+
+ AnswerNote:sconcat(": ", string([allowf, denyf])),
+ /* Are we closer to a deny string? */
+ if first(allowf)<first(denyf) then
+ return([true, false, StackAddNote("ATLevenshtein_deny", AnswerNote), ""]),
+ /* Are we sufficiently close to an allow string? */
+ if is(first(allowf)<tol) then
+ return([true, false, StackAddNote("ATLevenshtein_far", AnswerNote), ""]),
+
+ /* Is this basically a perfect match? */
+ if first(allowf)>=0.9999 then
+ return([true, true, StackAddNote("ATLevenshtein_true", AnswerNote), ""]),
+
+ return([true, true, StackAddNote("ATLevenshtein_match", AnswerNote), StackAddFeedback("", "ATLevenshtein_match", stack_disp(second(allowf), "i"))])
+)$
+
+/* **************************************** */
+/* Helper functions for string manipulation */
+/* **************************************** */
+
+/* Remove all the characters from the string rem from the string st.
+ Useful for removing all punctuation characters. */
+sremove_chars(rem, st) := sremove_chars_helper(charlist(rem), st)$
+sremove_chars_helper(remlist, st) := if emptyp(remlist) then st else sremove_chars_helper(rest(remlist), sremove(first(remlist), st))$
+
+/*
+ (1) Replace all tab and newline characters with spaces.
+ (2) Trim spaces from each end.
+ (3) Remove all multiple spaces and replace with a single space.
+
+ (This is called str_squish in the R language, and squish in other languages.).
+*/
+ssquish(st) := block(
+ st:ssubst(" ", tab, st),
+ st:ssubst(" ", newline, st),
+ st:strim(" ", st),
+ /* while is(slength(st)>slength(st:ssubst(" ", " ", st))) do true,*/
+ st:regex_subst(" ", "\\s+", st),
+ st
+)$
+
+/* **************************************** */
+/* A wrapper for an all purpose answer test
+ which checks things are of the same "type".
+ Based upon the results of AtAlgEquivfun(SA,SB)
+*/
+/* **************************************** */
ATSameType(SA, SB) := block([ret],
ret:ATSameTypefun(SA,SB),
/* This test gives no feedback */
@@ -1514,10 +1865,6 @@ ATSameType(SA, SB) := block([ret],
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)),
@@ -1573,22 +1920,28 @@ ATLowestTerms(SA, SB) := block([simp:false, ret, validity, mark, FeedBack, Answe
return([validity, mark, AnswerNote, FeedBack])
)$
-ATSubstEquiv(SA,SB) := block([simp:true, ret, SAc, SBc],
+ATSubstEquiv([ex]) := block([simp:true, SA, SB, SC, ret, SAc, SBc],
/* Turn on simplification and error catch */
- SA:errcatch(ev(SA, simp, nouns)),
+ SA:errcatch(ev(first(ex), simp, nouns)),
if is(SA=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_SAns"), ""]),
SA:SA[1],
- SB:errcatch(ev(SB, simp, nouns)),
+ SB:errcatch(ev(second(ex), simp, nouns)),
if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_TAns"), ""]),
SB:SB[1],
+ SC:[[]],
+ if length(ex)>2 then
+ SC:errcatch(ev(third(ex), simp, nouns)),
+ if is(SC=[STACKERROR]) then return([false, false, StackAddNote("", "ATSubstEquiv_STACKERROR_Opt"), ""]),
+ SC:SC[1],
+ if not(listp(SC)) then return([false, false, StackAddNote("", "ATSubstEquiv_Opt_List"), StackAddFeedback("", "ATSubstEquiv_Opt_List")]),
/* Copy SA and SB. If they are lists or matrices then ATAlgEquivfun potentially colours wrong entries. */
SAc:copy(SA),
SBc:copy(SB),
ret:ATAlgEquivfun(SAc, SBc),
/* Can we find a permutation of the variables? */
if ret[2]=false then block([p1],
- p1:subst_equiv(SA, SB),
- if p1#[] and p1#false then ret:[true, true, StackAddNote("", concat("ATSubstEquiv_Subst: ", string(p1))), StackAddFeedback("", "Subst", stack_disp(p1, "d"))]
+ p1:subst_equiv(SA, SB, SC),
+ if p1#[] and p1#false then ret:[true, true, StackAddNote("", concat("ATSubstEquiv_Subst ", string(p1))), StackAddFeedback("", "Subst", stack_disp(p1, "d"))]
),
/* Send back result */
return(ret)
@@ -1598,8 +1951,8 @@ ATSubstEquiv(SA,SB) := block([simp:true, ret, SAc, SBc],
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),
+ 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. */
@@ -1607,12 +1960,12 @@ ATLogic(SA, SB) := block([SAL, SBL, res],
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", ""]),
+ 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, "ATLogic_Solver_True", ""]),
+ 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), "]"),
@@ -1623,6 +1976,24 @@ ATLogic(SA, SB) := block([SAL, SBL, res],
return(res)
)$
+ATPropLogic(SA,SB) := block([simp:true, ret, SAc, SBc],
+ /* Turn on simplification and error catch */
+ SA:errcatch(ev(SA, simp, nouns)),
+ if is(SA=[STACKERROR]) then return([false, false, StackAddNote("", "ATPropLogic_STACKERROR_SAns"), ""]),
+ SA:SA[1],
+ SB:errcatch(ev(SB, simp, nouns)),
+ if is(SB=[STACKERROR]) then return([false, false, StackAddNote("", "ATPropLogic_STACKERROR_TAns"), ""]),
+ SB:SB[1],
+ /* We don't want noun forms getting in the way here. */
+ SA:noun_logic_remove(SA),
+ SB:noun_logic_remove(SB),
+ /* Can we find a permutation of the variables? */
+ if logic_equiv(SA, SB) then
+ return([true, true, "", ""]
+ ),
+ /* Send back result */
+ return([true, false, "", ""])
+)$
/**********************************************/
/* */
@@ -1681,24 +2052,23 @@ ATSysEquiv(SA,SB):=block([keepfloat,Validity, RawMark, FeedBack, AnswerNote, SAA
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")),
+ return(StackBasicReturn(false, false, "ATSysEquiv_SB_not_list")),
/* Are all list elements not atoms? */
- if ev(all_listp(atom,SA),simp) then
+ 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
+ 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
+ if ev(not all_listp(equationp, SB), simp) then
return(StackBasicReturn(false, false, "ATSysEquiv_SB_not_eq_list")),
- /* Turn our equations into expressions */
+ /* 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
@@ -1706,6 +2076,10 @@ ATSysEquiv(SA,SB):=block([keepfloat,Validity, RawMark, FeedBack, AnswerNote, SAA
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")),
@@ -1720,13 +2094,14 @@ ATSysEquiv(SA,SB):=block([keepfloat,Validity, RawMark, FeedBack, AnswerNote, SAA
*/
varlist: listofvars(S2),
- if not is(ev(setify(listofvars(S1)),simp)=ev(setify(varlist), simp)) then
+ 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,"",""]),
@@ -1788,8 +2163,14 @@ ATSysEquivGrob(GA, GB, SA, varlist) := block([retl, ret, kloop],
/*****************************************************************/
/* 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],
+ATCasEqual(SA,SB) :=
+ block([keepfloat:true, Validity:true, RawMark:false, FeedBack:"", AnswerNote:"", SAA, SBB, SAN, SBN],
+ SAN:copy(SA),
+ SBN:copy(SB),
+
+ /* Strip out previous simplificiation. */
+ SAN:parse_string(string(SAN)),
+ SBN:parse_string(string(SBN)),
SAA:errcatch(ev(SA, simp, nouns)),
if (is(SAA=[STACKERROR]) or is(SAA=[])) then return([false,false,StackAddNote("","ATCASEqual_STACKERROR_SAns"),""]),
@@ -1797,21 +2178,21 @@ ATCASEqual(SA,SB) :=
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
+ if equals_commute_associate(SAN,SBN) then
(RawMark:true, AnswerNote:"")
else
- (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss: (AlgEquiv:true)")),
+ (RawMark:false, AnswerNote:StackAddNote("","ATEqualComAss (AlgEquiv-true)")),
- if SA=SB then
+ if SAN=SBN then
return([Validity, true, StackAddNote("","ATCASEqual_true"), FeedBack]),
/* We need to check things are of the same type */
- ret:ATSameTypefun(SA,SB),
+ ret:ATSameTypefun(SAN,SBN),
if ret[2]=false then
- return([true, false, StackAddNote("ATCASEqual: ", StackTrimNote(ret[3])), ret[4]]),
- ret:block([simp:true, ret], ATAlgEquivfun(SA, SB)),
+ return([true, false, StackAddNote("ATCASEqual ", StackTrimNote(ret[3])), ret[4]]),
+ ret:block([simp:true, ret], ATAlgEquivfun(SAN, SBN)),
if ret[2]=true then
- return([true, false, StackAddNote("ATCASEqual: (AlgEquiv:true)", StackTrimNote(ret[3])), ""]),
+ return([true, false, StackAddNote("ATCASEqual (AlgEquiv-true)", StackTrimNote(ret[3])), ""]),
AnswerNote:"ATCASEqual_false",
return([Validity, RawMark, StackAddNote("",AnswerNote),FeedBack])
@@ -1869,84 +2250,79 @@ ATGTE(SA,SB) :=
/* (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? */
+/* Is p an irreducible polynomial term in v, over the rationals Q? */
/* Returns a list, of [true/false, FeedBack, true/false] */
/* The third argument is the special case when we just have an integer factor to pull out. Needed for PartFrac. */
-irred_Q(p,v) := block([ret,deg,cl,ci],
- 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]
+
+irred_Q(p, v) := block([ret,deg,cl,ci],
+ if ev(not(polynomialp(p, [v], lambda([ex], freeof(v, ex)))), simp) then return([false, StackAddFeedback("", "ATFacForm_notpoly")]),
+ deg:ev(hipow(expand(p), v), simp),
+ /* Now perform the general test. */
+ cl:ev(map(second, coeff_list_nz(expand(p), v)), simp),
+ /* Are all coefficients of p are integers? (note, negative number don't count as integers here!) */
+ ci:all_listp(lambda([ex], integerp(ev(abs(ex), simp))), cl),
+ /* General starting position. */
+ ret:[factorp(p), "", false],
+ /* Special cases. */
+ if is(deg=0) then ret:[true,"",false],
+ /* Special situation for the linear case to avoid strange results. */
+ if is(deg=1) then block([lt],
+ lt:ev(bothcoef(p, v), simp),
+ if lt[1]=1 or lt[2]=1 then ret:[true, "", false]
),
- /* Special case of quadratics, which are irreducible over the rationals */
- if 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]
+ /* Special case of quadratics, which are irreducible over the rationals. */
+ if is(deg=2) then block([a, b, c, q],
+ q:ev(expand(p), simp),
+ a:ev(coeff(q, v, 2), simp),
+ b:ev(coeff(q, v, 1), simp),
+ c:ev(coeff(q, v, 0), simp),
+ if (b=0 and c=0 and a>1 and ratnump(ev(sqrt(a), simp))) then ret:[true, StackAddFeedback("", "irred_Q_optional_fac", stack_disp(p,"i")), false]
+ else if (b=0 and c=0) then ret:[true, "", false]
+ else if ratnump(ev(sqrt(b^2-4*a*c), simp)) then ret:[false, "", false]
),
- /* Check we have a common integer factor: note can't use GCD function which only allows 2 arguments */
- if length(cl)>1 and ci and commonfaclist(cl)>1 then ret:[false,StackAddFeedback("","irred_Q_commonint"),true],
+ /* 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 */
+ /* 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]
+ 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],
+/* Picks apart an expression and gives some feedback */
+/* on why this is not a factored expression. */
+FacForm_UnPick(SA, SO) := block([negdistrib, partswitch, fb, kloop, irred, res, end],
negdistrib:false,
partswitch:true,
fb:"",
res:true,
- if 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)),
+ if safe_op(SA) = "-" then SA:part(SA,1),
+ if atom(SA) then return([true, ""]),
+ if op(SA) = "+" then return(irred_Q(SA, SO)) else
+ if op(SA) = "^" then return(irred_Q(part(SA, 1), SO)),
/* So we have a *, or a / */
- for kloop:1 step 1 while ev(part(SA, kloop),simp)#end do block(
+ 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, ""])
- ),
+ irred:block([SB],
+ SB:part(SA, ev(kloop, simp)),
+ if safe_op(SB) = "-" then SB:part(SB, 1),
+ if atom(SB) then return([true, ""]),
+ if safe_op(SB) = "+" then return(irred_Q(SB, SO)),
+ if safe_op(SB) = "^" then return(irred_Q(part(SB, 1), SO)) else return([false, ""])
+ ),
res:res and irred[1],
if irred[1] = false then block(
- fb:StackAddFeedback(fb, "FacForm_UnPick_morework",stack_disp(part(SA, ev(kloop, simp)), "i")),
+ fb: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:"",
@@ -1974,51 +2350,48 @@ ATFacForm(SA, SB, SO) := block([negdistrib, RawMark, FeedBack, AnswerNote, 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")
+ ansnote:StackAddNote(ansnote, "ATFacForm_int_true")
else block(
rawmk: false,
- ansnote: StackAddNote("", "ATFacForm_int_false")
- )
+ ansnote:StackAddNote(ansnote, "ATFacForm_int_false")
+ )
else block(
/* Check for the correct answer. */
if (aequiv and factorp(SA)) then
- ansnote: StackAddNote("", "ATFacForm_true")
+ ansnote:StackAddNote("", "ATFacForm_true")
else block(
- if (factorp(SA)) then ( /* We need to provide some feedback, if possible */
+ if (factorp(SA)) then block(
+ /* 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") ),
+ else block(
+ up:FacForm_UnPick(SA, SO),
+ if (up[1]=false) then block(
+ rawmk:false,
+ ansnote:StackAddNote(ansnote, "ATFacForm_notfactored"),
+ fb:StackAddFeedback(fb, "ATFacForm_notfactored"),
+ fb:concat(fb, up[2])
+ ) else block(
+ ansnote:StackAddNote(ansnote, "ATFacForm_default_true")
+ )
+ ),
/* Check for algebraic equivalence */
if (true#aequiv) then (
- rawmk:false,
- ansnote:StackAddNote(ansnote, "ATFacForm_notalgequiv"),
- fb:StackAddFeedback(fb, "ATFacForm_notalgequiv")
- )
+ rawmk:false,
+ ansnote:StackAddNote(ansnote, "ATFacForm_notalgequiv"),
+ fb:StackAddFeedback(fb, "ATFacForm_notalgequiv")
)
- ),
- ret: [val, rawmk, ansnote, fb],
+ )
+ ),
+ 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. */
@@ -2045,7 +2418,7 @@ ATExpanded(SA,SB) :=
/* [Teachers Question, */
/* Respect To which the fractions are parted, */
/* Formative Feedback] */
-/* returns: StackReturn */
+/* returns: [validity,rawmk,ansnote,fb] */
/* CASE 1: topOp is divisor - single fraction */
/* CASE 2: CORRECT answer - true */
/* CASE 3: Different Variables - diff vars */
@@ -2057,7 +2430,7 @@ ATExpanded(SA,SB) :=
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:"",
+ Validity:true, rawmk:true, fb:"", ansnote:"",
SAA:errcatch(ev(SA, simp, nouns)),
if (is(SAA=[STACKERROR]) or is(SAA=[])) then
@@ -2083,100 +2456,97 @@ ATPartFrac(SA, SB, SO) := block([negdistrib, Validity, rawmk, fb, ansnote, ret,
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]
- ),
+/* An expression is in partial fraction form when */
+/* it is a sum of rational terms. In each term */
+/* - the denominator of each term is a power of an */
+/* irreducible (not factorable) polynomial and */
+/* - the numerator is a polynomial of smaller degree */
+/* than that irreducible polynomial. */
+/* It is tempting to try something like the following. */
+/* tapf:ev(partfrac(ratsimp(tExpr), wrt), simp); */
+/* rawmk:second(ATEqualComAss(sExpr, tapf)); */
+/* There are at least two problems with this approach. */
+/* (i) partfrac returns terms like (1+n)^-1 not 1/(1+n), */
+/* which are problematic with simp:false. */
+/* (ii) ATEqualComAss does not accept -1/(1-n) = 1/(n-1) */
+PartFracfun(sExpr, tExpr, wrt) := block([val, rawmk, ansnote, fb, ret],
+ val:true, rawmk:true, fb: "", ansnote: "",
+ ret:[val, rawmk, ansnote, fb],
+ if algebraic_equivalence(sExpr, tExpr) then block([topOp, list],
+ topOp:op(sExpr),
+ list:args(sExpr),
+ /* Sort out any factors the student may have pulled out */
+ if topOp = "*" then block(
+ sExpr:expand(sExpr),
+ topOp:op(sExpr),
+ list:args(sExpr)
+ ),
+ if topOp = "/" then list:[sExpr] else list:args(sExpr),
+ block([sargs, sdenoms],
+ val:true,
+ rawmk:true,
+ ansnote:StackAddNote("", "ATPartFrac_true"),
+ /* We need to check that each term in the student's sum is in lowest terms ... */
+ if not all_listp(lambda([ex], real_numberp(gcd(num(ex), denom(ex)))), list) then block(
+ rawmk:false,
+ ansnote:StackAddNote("", "ATPartFrac_false_lowestterms")
+ ),
+ /* We need to check that each denominator is the power of an irreducible factor */
+ if not all_listp(lambda([ex], PartFrac_term_p(ex, wrt)), list) then block(
+ rawmk:false,
+ ansnote:StackAddNote("", "ATPartFrac_false_factor")
+ )
+ ),
+ ret:[val, rawmk, ansnote, fb],
+ return(ret)
+ )
+ else if sameVars(sExpr, tExpr) then block([sDeg, tDeg, sNDeg, tNDeg],
+ sDeg: ev(hipow(expand(denom(factor(sExpr))), wrt), simp),
+ tDeg: ev(hipow(expand(denom(factor(tExpr))), wrt), simp),
+ sNDeg: ev(hipow(expand(num(factor(sExpr))), wrt), simp),
+ tNDeg: ev(hipow(expand(num(factor(tExpr))), wrt), simp),
+ if tDeg # sDeg then block(
+ val:true,
+ rawmk:false,
+ ansnote:StackAddNote("", "ATPartFrac_denom_ret"),
+ fb: StackAddFeedback("", "ATPartFrac_denom_ret", stack_disp(denom(factor(sExpr)), "i"), stack_disp(denom(factor(tExpr)), "i")),
+ ret: [val, rawmk, ansnote, fb],
+ return(ret)
+ ) else block(
+ val:true,
+ rawmk:false,
+ ansnote:StackAddNote("", "ATPartFrac_ret_expression"),
+ fb:StackAddFeedback("", "ATPartFrac_ret_expression", stack_disp(factor(sExpr), "i")),
+ ret:[val, rawmk, ansnote, fb]
+ )
+ ) else block(
+ val:false,
+ rawmk:false,
+ ansnote:StackAddNote("", "ATPartFrac_diff_variables"),
+ fb:StackAddFeedback("", "ATPartFrac_diff_variables"),
+ ret:[val, rawmk, ansnote, fb]
+ ),
return(ret)
- )$
+)$
+
+/* Is ex a single rational expression in the correct form? */
+/* p/q^n, where q is an irreducible term in v, over the rationals Q, disregarding the special case of a numerical factor? */
+/* We also make sure we can't do long division to divide p by p^n first. */
+/* Returns true/false */
+PartFrac_term_p(ex, v) := block([n1, d1, ret],
+ n1:num(ex),
+ d1:denom(ex),
+ /* Can we divide through? */
+ if is((degree(d1, v) < degree(n1, v)) and degree(d1, v) > 0) then return(false),
+ /* Ignore any power here. */
+ if safe_op(d1)="^" then d1:first(args(d1)),
+ /* Terms of the form n1/(v-a)^m must have a numerical n1! */
+ if is(degree(d1, v) = 1) and (degree(n1, v)#0) then return(false),
+ ret:irred_Q(d1, v),
+ if third(ret) then true else first(ret)
+)$
/* ************************ATSingFracTest****************************** */
-/* 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,
@@ -2206,11 +2576,11 @@ ATSingleFrac(SA, SB) := block(
/* 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(
+ 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")
)
@@ -2229,6 +2599,15 @@ ATSingleFrac(SA, SB) := block(
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 */
@@ -2237,13 +2616,13 @@ ATSingleFrac(SA, SB) := block(
divthru(q) :=
if (not atom(q) and part(q,0)="/")
then
- block([num, den, div, quo, rem],
+ block([num,den,divt,quo,rem],
num:part(q, 1),
den:part(q, 2),
- div:divide(num, den) ,
- quo:div[1],
- rem:div[2],
- quo+rem/ den )
+ divt:divide(num, den) ,
+ quo:divt[1],
+ rem:divt[2],
+ quo+rem/den )
else q;
/*****************************************************************/
@@ -2355,7 +2734,7 @@ ATCompSquare(SA, SB, SO) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,
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"))]),
+ return([true, false, StackAddNote("", "ATCompSquare_SA_not_depend_var"), StackAddFeedback("", "ATCompSquare_SA_not_depend_var", stack_disp(wrt, "i"))]),
opa:safe_op(SA),
@@ -2366,6 +2745,14 @@ ATCompSquare(SA, SB, SO) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,
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,
@@ -2389,12 +2776,15 @@ ATCompSquare(SA, SB, SO) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,
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))))),
+ 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
)
@@ -2414,7 +2804,6 @@ ATCompSquare(SA, SB, SO) := block([Validity,RawMark,FeedBack,AnswerNote,ret,wrt,
return([true,false,StackAddNote("",AnswerNote),StackAddFeedback("",AnswerNote)])
)$
-
/*********************/
/* Calculus question */
/*********************/
@@ -2445,7 +2834,7 @@ strip_int_const(ex, v) := block([ex2,fargs],
/* 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],
+ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, AnswerNote, var, sbdisp, ret, cont, constint, acceptformal, atoptions],
oldsimp:simp,
simp:false,
Validity:true, RawMark:false,
@@ -2453,6 +2842,8 @@ ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, Ans
keepfloat:true,
/* Should we be fussy about the constant of integration? */
constint:true,
+ /* Should we accept formal derivatives? */
+ acceptformal:false,
/* How to display the teacher's answer? */
sbdisp:[],
@@ -2466,6 +2857,9 @@ ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, Ans
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
@@ -2474,6 +2868,7 @@ ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, Ans
*/
if listp(var) then block(
atoptions:ATIntOptions(var),
+ if debug then print("Options: ", atoptions),
if not(equal(first(atoptions), "")) then block(
print("TEST_FAILED"),
cont:false,
@@ -2483,7 +2878,8 @@ ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, Ans
),
var:second(atoptions),
constint:third(atoptions),
- sbdisp:fourth(atoptions)
+ acceptformal:fourth(atoptions),
+ sbdisp:fifth(atoptions)
),
/* If we haven't explicitly got a displayed expression for feedback then generate one. */
@@ -2492,48 +2888,50 @@ ATInt(sa, sb, so) := block([oldsimp, keepfloat, Validity, RawMark, FeedBack, Ans
ret:[true, RawMark, AnswerNote, FeedBack],
- /*print([sa, sb, sbdisp, constint, var, cont]),*/
+ /* 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)
+ ret:Intfun(sa, sb, sbdisp, constint, acceptformal, var)
),
simp:oldsimp,
return(ret)
)$
/* This function sorts out the possible option combinations for the answer test, checks them and
- returns them in a known consistent way. */
-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]
+ returns them in a known consistent way.
+ Options currently are as follows:
+ [NOCONST, FORMAL, spdisp]
where
NOCONST = true or false. Are we strict in requiring a constant of integration?
+ FORMAL = true or false. Are allow anything which is the formal derivative.
sbdisp = ?, any expression which the teacher wants to display instead of an auto-generated derivative of the teacher's answer.
Other options can be added as needed.
-*/
-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)]))
+ */
+ATIntOptions(opts) := block([note, var, atopts, optdefaults],
+ note:"",
+ /* Add in default values for the options here. See ATIntOptionsHelper for details.*/
+ optdefaults:[true, false, []],
+ if emptyp(opts) or not(is(length(opts)<5)) then return(["ATInt_STACKERROR_OptList", x, 0, true]),
+ var:first(opts),
+ atopts:setify(rest(opts)),
+ if elementp(NOCONST, atopts) then block(
+ atopts:setdifference(atopts,{NOCONST}),
+ optdefaults[1]:false
+ ),
+ if elementp(FORMAL, atopts) then block(
+ atopts:setdifference(atopts,{FORMAL}),
+ optdefaults[2]:true
+ ),
+ /* If there is a display expression, then use it. */
+ if not(emptyp(atopts)) then optdefaults[3]:first(listify(atopts)),
+ return(append([note,var], optdefaults))
)$
-Intfun(SA, SB, SBdisp, constint, var) := block([val,rawmk,ansnote,fb,ret,ex,SAd,SBd,SBraw,saa,dd,dc,lSAv,lSBv,mSAv,mSBv,SAConsistentLogs,SAUsedLogAbs,SBUsedLogAbs],
+Intfun(SA, SB, SBdisp, constint, acceptformal, var) := block([val,rawmk,ansnote,fb,ret,ex,SAd,SBd,SBraw,saa,dd,dc,lSAv,lSBv,mSAv,mSBv,SAConsistentLogs,SAUsedLogAbs,SBUsedLogAbs],
val:true, rawmk:false, fb:"", ansnote:"",
- 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!*/
@@ -2599,7 +2997,7 @@ Intfun(SA, SB, SBdisp, constint, var) := block([val,rawmk,ansnote,fb,ret,ex,SAd,
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"))
+ (rawmk:acceptformal, fb:StackAddFeedback("", "ATInt_EqFormalDiff"), ansnote:StackAddNote("", "ATInt_EqFormalDiff"))
) else /* Check for the special cases where the buggy rule is true. */
if ev(algebraic_equivalence(SAa, ev(diff(SBd, var), simp)), simp) and ev(algebraic_equivalence(exp(x), SBd), simp)#true then
(rawmk:false, fb:StackAddFeedback("", "ATInt_diff"), ansnote:StackAddNote("", "ATInt_diff"))
@@ -2685,6 +3083,13 @@ ATInt_consistent_logabs_p(ex, var):=block([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, */
@@ -2692,7 +3097,7 @@ ATInt_consistent_logabs_p(ex, var):=block([helper],
/********************************************************************/
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:"",
+ old_simp:simp, simp:false, RawMark:false, FeedBack:"", AnswerNote:"",
keepfloat:true,
SAA:errcatch(ev(sa, simp, nouns)),
@@ -2702,6 +3107,9 @@ ATDiff(sa, sb, so) :=
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")])
@@ -2711,32 +3119,44 @@ ATDiff(sa, sb, so) :=
),
simp:old_simp,
return(ret)
- )$
+)$
-Difffun(SA,SB,v) := block([val,rawmk,ansnote,fb,ret,lSAv,lSBv,mSAv,mSBv],
+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"))
+ 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 (
+ 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),
+ 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 */
+ 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],
+ 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)))
+)$
/* ****************************************************** */
/* */
@@ -2772,9 +3192,112 @@ assess(ex1,ex2):=block([ret],
return("")
)$
+/* ****************************************************** */
+/* */
+/* Tables */
+/* */
+/* ****************************************************** */
+
+/* A function to create a truth table of an expression ex. */
+truth_table(ex) := block([exs, vars, tab, tt],
+ vars: ev(sort(listofvars(ex)),simp),
+ if length(vars) > 5 then error("truth_table will only print with fewer than 6 variables."),
+ /* Store this variable to prevent 2^n re-evaluations of this function. */
+ exs: noun_logic_remove(ex),
+ tab: maplist(lambda([ex2], zip_with("=", vars, ex2)), truth_table_allvars(vars)),
+ tab: maplist(lambda([ex2], append(maplist(rhs, ex2), [ev(logic_simp(exs), ex2)])), tab),
+ tab: append([append(vars, [ex])], tab),
+ apply(table, tab)
+)$
+
+truth_table_allvars(l) := block(
+ if emptyp(l) then return([[]]),
+ return(append( maplist(lambda([ex], append([false], ex)), truth_table_allvars(rest(l))),
+ maplist(lambda([ex], append([true], ex)), truth_table_allvars(rest(l)))))
+)$
+
+/* This variable controls whether boolean true/false are abbreviated to T/F respectivley when printing tables. */
+table_bool_abbreviate:true$
+table_bool_abbreviate_fn(ex):= block(
+ if safe_op(ex) = "texcolor" then return(sconcat("\\color{", first(args(ex)), "}{\\underline{", table_bool_abbreviate_fn(second(args(ex))), "}}")),
+ if table_bool_abbreviate=true then
+ return(if ex=true then "\\mathbf{T} " else if ex=false then "\\mathbf{F} " else stack_disp(ex, ""))
+ else stack_disp(ex, "")
+)$
+
+table_tex(ex):= block([ret, astart],
+ /* Make a header. */
+ astart: ev(makelist("c", k, length(first(ex))), simp),
+ astart: sconcat("\\begin{array}{", simplode(astart, "|"), "} "),
+ ret: matrixmap(table_bool_abbreviate_fn, apply(matrix, args(ex))),
+ ret: maplist(lambda([ex2], simplode(ex2, " & ")), args(ret)),
+ rest:sconcat(astart, first(ret), "\\\\ \\hline ", simplode(rest(ret), " \\\\ "), "\\end{array} ")
+)$
+texput(table, table_tex)$
+
+table_zip_with(fn, T1, T2) := block(
+ apply(table, zip_with(lambda([ex1,ex2], zip_with(fn,ex1,ex2)), args(T1), args(T2)))
+)$
+
+table_difference(T1, T2) := table_zip_with(lambda([ex1,ex2], if ex1=ex2 then ex1 else texcolor("red", ex1)), T1, T2)$
+
+/* ****************************************************** */
+/* */
+/* Trees */
+/* */
+/* ****************************************************** */
+disptree(e) := sconcat("<ul class='tree'><li>", tree_rec(e), "</li></ul>");
+
+/* A list of functions which should use the TeX representation. (Defined as a list to be user-editable) */
+
+tree_texlist:{"#pm#", "%union", "%intersection"};
+tree_rec(e) := block([treelist],
+ if atom(e) then return(sconcat("<span class='atom'>", stack_disp(e, "i") ,"</span>")),
+ if is(safe_op(e)="treestop") then return(sconcat("<span class='atom'>", stack_disp(first(e), "i") ,"</span>")),
+ if is(safe_op(e)="matrix") then return(sconcat("<span class='atom'>", stack_disp(e, "i") ,"</span>")),
+ if is(safe_op(e)="binomial") then return(sconcat("<span class='atom'>", stack_disp(e, "i") ,"</span>")),
+ if is(safe_op(e)="disp_parens") then return(tree_rec(first(ex))),
+
+ treelist:flatten(["<code>", op(noun_logic_remove(e)), "</code><ul>", map(lambda([ex], sconcat("<li>", tree_rec(ex) ,"</li>")), args(e)), "</ul>"]),
+
+ /* Lots of opportunities/need for fine-tuning. */
+
+ if is(safe_op(e)="int") then treelist:flatten(["<span class='op'>\\(\\int \\cdots \\mathrm{d}", stack_disp(second(e), ""), " \\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+ if is(safe_op(e)="diff") then treelist:flatten(["<span class='op'>\\(", stack_disp(apply(noundiff, append([NULLNUM], rest(args(e)))), ""), " \\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+ if is(safe_op(e)="sum" or safe_op(e)="'sum") then treelist:flatten(["<span class='op'>\\(\\sum_{", stack_disp(second(e), ""), "=", stack_disp(third(e), ""), "}^{", stack_disp(fourth(e), ""), "} \\cdots \\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+ if is(safe_op(e)="limit" or safe_op(e)="'limit") then treelist:flatten(["<span class='op'>\\(\\lim_{", stack_disp(second(e), ""), "\\rightarrow{", stack_disp(third(e), ""), "}} \\cdots \\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+ /* This example mirrors tex-gamma. */
+ if is(safe_op(e)="gamma") then treelist:flatten(["<span class='op'>\\(\\Gamma\\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+ /* This example mirrors tex-sqrt. */
+ if is(safe_op(e)="sqrt") then treelist:flatten(["<span class='op'>\\(\\sqrt{}\\)</span><ul><li>", tree_rec(first(e)), "</li></ul>"]),
+
+ if elementp(safe_op(e), tree_texlist) or logicp(e) then block(
+ /* Apply the operator to as many arguments as we have, none of which print. */
+ treelist:["<span class='op'>\\(", stack_disp(apply(op(e), ev(makelist(NULLNUM,k,1,length(args(e))),simp)), ""), "\\)</span>"],
+ /* Try to get a symbol from the tex database, to avoid empty brackets round functions. */
+ if symbolp(op(e)) then block([%_do],
+ if not(stringp(%_do:get_texword(op(e)))) then %_do:get_texsym(op(e)),
+ treelist:["<span class='op'>\\(", %_do, "\\)</span>"]
+ ),
+ treelist:flatten(append(treelist, ["<ul>", map(lambda([ex], sconcat("<li>", tree_rec(ex) ,"</li>")), args(e)), "</ul>"]))
+ ),
+
+ apply(sconcat, treelist)
+)$
+
+
+/* ****************************************************** */
+/* */
+/* End of file processes */
+/* */
+/* ****************************************************** */
/* Slight hack to compile these functions and hence suppress warnings. */
load(linearalgebra);
+/* Initialise the language-code delivery, for special cases. */
+%_STACK_LANG: "en"$
+is_lang(code):=ev(is(%_STACK_LANG=code),simp=true)$
+
/* Stack expects some output with the version number the output happens at */
/* maximalocal.mac after additional library loading */
-stackmaximaversion:2017121800$
+stackmaximaversion:2023102700$
diff --git a/stack/2017121800/maxima/stackreporting.mac b/stack/2023102700/maxima/stackreporting.mac
similarity index 94%
rename from stack/2017121800/maxima/stackreporting.mac
rename to stack/2023102700/maxima/stackreporting.mac
index 1d7ba4343cf1b7eddc6d073ec02ca9600a4c3b93..14f9dd717a668bad6d7ff1effbf97aac8d58f67e 100644
--- a/stack/2017121800/maxima/stackreporting.mac
+++ b/stack/2023102700/maxima/stackreporting.mac
@@ -20,7 +20,7 @@ stack_equiv_classes(l):=block(
/* 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."),
+ error("stack_analysis: this function has not yet been implemented. Please see the maxima code directly for examples of how to analyse data."),
false
)$
diff --git a/stack/2023102700/maxima/stackstrings.mac b/stack/2023102700/maxima/stackstrings.mac
new file mode 100644
index 0000000000000000000000000000000000000000..a0d2cb42d8decc155f3ef7aa072f6e17c539f444
--- /dev/null
+++ b/stack/2023102700/maxima/stackstrings.mac
@@ -0,0 +1,446 @@
+/* Various string processing tools, primarily for parsing and generating JSON. */
+
+
+/* First some functions for dealing with stack_maps. */
+
+/* A map is a list of key value pairs with the first element being the string "stack_map" */
+/* We intentionally skip the use of structs to allow people to directly process the "map" */
+/* from within STACK question code as structs were still forbidden there at the time. */
+/* Also avoiding certain list convenience functions as they are quite recent additions */
+/* to Maxima, so do not wonder why things are done at quite a low level. */
+is_stackmap(x) := ev(listp(x) and is(length(x)>0) and is(x[1]="stack_map"), simp)$
+/* might as we be called stackmapp() but that sounds odd. */
+stackmapp(x) := is_stackmap(x)$
+
+stackmap_get(m, k) := block([],
+ if not is_stackmap(m) then return(und),
+ return(assoc(k,rest(m,1),und))
+)$
+
+/* Either take the value from the map, or use the value of the atom. */
+stackmap_get_ifexists(m, k) := block([],
+ if not is_stackmap(m) then return(m),
+ return(assoc(k,rest(m,1),und))
+)$
+
+stackmap_set(m, k, v) := block([],
+ /* If we are given anything else than a map as the map we make a new map. */
+ if not is_stackmap(m) then return(["stack_map",[k,v]]),
+ /* Find all others. */
+ return(append(["stack_map"],sublist(rest(m,1), lambda([x],is(x[1]#k))),[[k,v]]))
+)$
+
+stackmap_unset(m, k) := block([],
+ if not is_stackmap(m) then return(und),
+ return(append(["stack_map"],sublist(rest(m,1), lambda([x],is(x[1]#k)))))
+)$
+
+stackmap_keys(m) := block([],
+ if not is_stackmap(m) then return(und),
+ return(map(lambda([x], x[1]), rest(m,1)))
+)$
+
+stackmap_values(m) := block([],
+ if not is_stackmap(m) then return(und),
+ return(map(lambda([x], x[2]), rest(m,1)))
+)$
+
+stackmap_has_key(m, k) := block([tmp, found],
+ found: false,
+ if not is_stackmap(m) then return(false),
+ for tmp in rest(m,1) do (if is(tmp[1]=k) then (found:true,break)),
+ return(found)
+)$
+
+
+/* This function takes a string containing JSON and returns a list, number, string, */
+/* boolean or a stackmap depending on what if finds. Should it find null or empty */
+/* input it returns und. */
+/* Note that we do use stringproc. */
+stackjson_parse(json) := block([r,tmp,tokens,mode,i,lastslash,c,starts,nt,k,v,dm],
+ r: und,
+ if not stringp(json) or is(json="") then return(und),
+ tmp:strim(sconcat(ascii(32),ascii(9),ascii(10),ascii(11),ascii(12),ascii(13)),json),
+ if is(tmp="") then return(und),
+
+ /* Easy ones. */
+ if is(tmp="true") then return(true),
+ if is(tmp="false") then return(false),
+ if is(tmp="null") then return(und),
+ if is(tmp="[]") then return([]),
+ if is(tmp="{}") then return(["stack_map"]),
+
+ /* Not easy, do some tokenising. */
+ mode:"raw", /* In a string or not, maybe number */
+ i:0,
+ tokens:[],
+ lastslash:false,
+ while ev(is(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)
+)$
+
+stackjson_protect_escapes(c) := if c = "\\" then "\\\\"
+ else if c = "\"" then "\\\""
+ else if c = ascii(8) then "\\b"
+ else if c = ascii(9) then "\\t"
+ else if c = ascii(10) then "\\n"
+ else if c = ascii(12) then "\\f"
+ else if c = ascii(13) then "\\r"
+ else c$
+
+/* Takes pretty much anything and turns it to a JSON string */
+stackjson_stringify(obj) := block([tmp,r,l],
+ r:und,
+ if is(obj=und) then r:"null"
+ else if is(obj=false) then r:"false"
+ else if is(obj=true) then r:"true"
+ else if stringp(obj) then (
+ r : sconcat("\"",simplode(map(stackjson_protect_escapes, charlist(obj))),"\"")
+ ) else if is_stackmap(obj) then (
+ l:[],
+ for tmp in stackmap_keys(obj) do l:append(l,[sconcat(stackjson_stringify(tmp),":",stackjson_stringify(stackmap_get(obj,tmp)))]),
+ r:sconcat("{",simplode(l,","),"}")
+ ) else if listp(obj) and length(obj) > 0 then r:sconcat("[",simplode(makelist(stackjson_stringify(x),x,obj),","),"]")
+ else if listp(obj) then r:"[]"
+ else if integerp(ev(obj,simp)) then r:string(ev(obj,simp))
+ else if numberp(ev(float(obj),simp)) then r:string(float(ev(float(obj),simp)))
+ else r:stackjson_stringify(string(obj)),
+ return(r)
+)$
+
+
+/**
+ * Special tools for dealing with CASText2.
+ *
+ * These tools are very advanced and probably not for a novice author.
+ * Essentially, these are useful if one generates CASText2 values inside
+ * keyval-fields and/or stores them into the state in Stateful.
+ * The only real use for a raw CASText2 value is to be outputted
+ * by the castext-block within castext itself.
+ *
+ * Note that while it is possible to manually construct a CASText2
+ * value the preferred way is to use the compiler logic and just
+ * write normal, although escaped, CASText inside a Maxima-string
+ * and let the compiler deal with it.
+ */
+/**
+ * Condenses the result of a CASText2 expression. Speeds PHP-side
+ * parsing and lessens the transferred bytes.
+ */
+castext_simplify(ct2) := block([_r,_i,_t,_redo],
+ if stringp(ct2) then return(ct2),
+ if listp(ct2) then (
+ _i:0,
+ _redo:false,
+ _r:[ct2[1], castext_simplify(ct2[2])],
+ if is(ct2[1]="%root") then _i:2,
+ /* We especially want to try to simplify jsxgraph-block content.
+ * It is likely to be highly fragmented with plenty of injections.
+ * That block now maps to the `iframe` block.
+ */
+ if is(ct2[1]="iframe") then (_i:3, _r: append(_r,[castext_simplify(ct2[3])])),
+ if is(_i>0) then (
+ if listp(last(_r)) and is(last(_r)[1]="%root") then (
+ _redo: true,
+ _r : append(firstn(_r, ev(length(_r) - 1, simp)), rest(last(_r)))
+ ),
+ while _i < length(ct2) do (
+ _i: ev(_i + 1, simp),
+ _t: castext_simplify(ct2[_i]),
+ if stringp(_t) and stringp(last(_r)) then (
+ _r[length(_r)] : sconcat(last(_r), _t)
+ ) else if listp(_t) and is(_t[1]="%root") then (
+ /* If we do this we may skip simplification of terms. */
+ _redo: true,
+ _r : append(_r, rest(_t))
+ ) else (
+ _r : append(_r, [_t])
+ )
+ ),
+ if is(_r[1]="%root") and is(length(_r)=2) and stringp(_r[2]) then (
+ return(_r[2])
+ ),
+ if _redo then return(castext_simplify(_r)),
+ return(_r)
+ )
+ ),
+ return(ct2)
+)$
+
+/**
+ * A concat for castext2. If you need to concat more terms lreduce...
+ */
+castext_concat(a, b) := block([_tmp, _a, _b],
+ _a: castext_simplify(a),
+ _b: castext_simplify(b),
+ if stringp(_a) and stringp(_b) then return(sconcat(_a, _b)),
+ return(castext_simplify(["%root", _a, _b]))
+)$
+
+/**
+ * For now we include this as a predicate function not a full answer test.
+ */
+regex_match_exactp(regex, str) := block([l1, bool1],
+ l1:regex_match(regex, str),
+ bool1:listp(l1),
+ if bool1 then block([strmatch],
+ strmatch:first(l1),
+ bool1:sequal(str, strmatch)
+ ),
+return(bool1))$
+
+/* STACK csv-helpper special tool for file output generation.
+ * Generates a string in CSV format of a list of lists or a matrix
+ * with an optional list of labels
+ * Will use normal grind/string style value form output but will return a castext list ["%root", ...]
+ * with values without Maxima style escapes. Special handling for pure float
+ * values, with them will use `stackfltfmt` to tune display.
+ * Uses "-wrapped strings when need be and picks , or ; as the separator
+ * based on how many values would need to be wrapped.
+ * We could do this with numericalio but we like to have that float formatting there.
+ */
+stack_csv_formatter(_data, _labels) := block([_sep,simp,_out,_rowcount,_sepcount1,_sepcount2],
+ _out:args(_data),
+ _sepcount1:0, /* for , */
+ _sepcount2:0, /* for ; */
+ /* Start by joining the values to labels if any */
+ if (listp(_labels)) then (
+ _out: append([_labels], _out)
+ ),
+
+ /* Render */
+ for _rowcount:1 thru length(_out) do (
+ _out[_rowcount]:maplist(lambda([_v],block([_tmp,_wrap],
+ _tmp: "NULL",
+ if (stringp(_v)) then (
+ _tmp: _v
+ ) else if ev(numberp(_v) and not integerp(_v), simp) then (
+ /* Those special floats, simp for the unary minus. */
+ _tmp: stack_disp(_v, "")
+ ) else (
+ _tmp: string(_v)
+ ),
+ _wrap: false,
+ if (integerp(sposition("\"", _tmp))) then (
+ _wrap: true,
+ /* Tricky bit we need to replace " with "" here, so ssubst just won't do. */
+ _tmp: simplode(maplist(lambda([c],if is(c="\"") then "\"\"" else c), charlist(_tmp)))
+ ),
+ /* If any line changes are in play wrap. */
+ if (integerp(sposition("
+", _tmp))) then _wrap: true,
+ /* If we have special whitespace at the ends of the value we need that wrapping. */
+ /* NOTE that the tab on the next line matters. */
+ if is(_tmp#strim("
+",_tmp)) then _wrap:true,
+
+ /* Check the separator situation */
+ if (not _wrap) then (
+ if (integerp(sposition(",", _tmp))) then _sepcount1: _sepcount1+1,
+ if (integerp(sposition(";", _tmp))) then _sepcount2: _sepcount2+1
+ ),
+
+
+ if (_wrap) then (
+ _tmp: sconcat("\"", _tmp, "\"")
+ ),
+ _tmp
+ )),_out[_rowcount])
+ ),
+
+ _sep:"fail",
+ /* Pick the separator. */
+ if _sepcount1 = 0 then (
+ _sep: ","
+ ) else if _sepcount2 = 0 then (
+ _sep: ";"
+ ),
+
+ if sep = "fail" then (
+ /* We need to wrap things to allow the use of our separator. */
+ _sep: ",",
+ for _rowcount:1 thru length(_out) do (
+ _out[_rowcount]:maplist(lambda([_v],block([_tmp],
+ _tmp: _v,
+ if not integerp(sposition("\"", _tmp)) then (
+ if integerp(strpos(_sep, _tmp)) then _tmp: sconcat("\"", _tmp, "\"")
+ ),
+ _tmp
+ )),_out[_rowcount])
+ )
+ ),
+
+ /* TODO: do we want to do padding and formatting to help reading in text-editors? */
+
+ /* Now let's join everything up. */
+ _out: maplist(lambda([_row], simplode(_row, _sep)), _out),
+ _out: simplode(_out,"
+"),
+ /* We might want to add a line change to the end. */
+ return(["%root", _out])
+)$
+
+
+
+/**
+ * The logic for turning {@%_val@} to a string, this exists to simplify
+ * castext2 compilation results.
+ * %_mode has the following values:
+ * "i" => sconcat("\({",...,"}\)") or ... for strings
+ * "im" => sconcat("\\\\\\({",str_to_md(...),"}\\\\\\)") or str_to_md(...) for strings
+ * "" => ...
+ * "m" => str_to_md(...)
+ * Basically the mode tells if we are to wrap things in math-delimiters and if we are in
+ * markdown mode.
+ */
+ct2_latex(%_val, %_mode, %_simp):=block([%_tmp,simp],
+ simp:false,
+ %_tmp: %_val,
+ /* Strings */
+ if stringp(%_tmp) then (
+ /* If in math-mode, i.e. not requesting wrapping wrap with braces. */
+ if %_mode = "" or %_mode = "m" then %_tmp: sconcat("{", %_tmp, "}"),
+ if %_mode = "m" or %_mode = "im" then %_tmp: str_to_md(%_tmp),
+ return(["smlt", %_tmp])
+ ) else if listp(%_tmp) and length(%_tmp) > 0 and is(%_tmp[1] = "%root") then (
+ /* If we receive inline CASText then pass it through. */
+ if is(length(%_tmp) = 2) then
+ return(%_tmp[2]), /* Unwrap it as it does not need that wrapping anymore. Unfortunately can only do this for the single elemetn case here. */
+ return(%_tmp)
+ ) else (
+ simp: %_simp,
+ %_tmp: stack_disp(%_tmp, ""), /* Do our own wrapping. */
+ %_tmp: sconcat("{", strimr(" ", %_tmp), "}"),
+ if %_mode = "i" or %_mode = "im" then %_tmp: sconcat("\\(", %_tmp, "\\)")
+ ),
+ if %_mode = "m" or %_mode = "im" then (
+ %_tmp: str_to_md(%_tmp)
+ ),
+ /* Finally give it to PHP side translations. Maybe move them here as well? */
+ return(["smlt", %_tmp])
+)$
+
diff --git a/stack/2017121800/maxima/stacktex.lisp b/stack/2023102700/maxima/stacktex.lisp
similarity index 63%
rename from stack/2017121800/maxima/stacktex.lisp
rename to stack/2023102700/maxima/stacktex.lisp
index 5e971bc03d25547fb1ea5ea93d2c0b0b05caf209..703e56a35170275efbb7eebf5d67d4466cf580f4 100644
--- a/stack/2017121800/maxima/stacktex.lisp
+++ b/stack/2023102700/maxima/stacktex.lisp
@@ -78,20 +78,7 @@
(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
'(
@@ -173,7 +160,7 @@
(defun tex-derivative (x l r)
(tex (if $derivabbrev
(tex-dabbrev x)
- (tex-d x '"\\mathrm{d}")) l r lop rop ))
+ (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
@@ -181,14 +168,20 @@
(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)
+ (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 `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
+ (numer (mfuncall `$simplify `((mexpt) ,dsym ((mplus) ,@ords)))) ; d^n numerator
(denom (cons '($blankmult)
(mapcan #'(lambda(b e)
- `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
+ `(,dsym ,(simplifya (mfuncall `$simplify `((mexpt) ,b ,(mfuncall `$simplify e))) nil)))
vars ords))))
- `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom)
+ (if (symbolp arg)
+ `((mquotient) (($blankmult) ,(simplifya numer nil) ,arg) ,denom)
+ `(($blankmult) ((mquotient) ,numer ,denom) ,arg)
+ )
))
@@ -215,6 +208,7 @@
;; Change the display of integrals to be consistent with derivatives.
;; Chris Sangwin, 8/6/2015.
+(defprop %int tex-int tex)
(defprop %integrate tex-int tex)
(defun tex-int (x l r)
(let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integran, at the request of the OU delims / & d
@@ -241,6 +235,12 @@
'("}"))))
(append l front back r)))
+;; Powers of functions are displayed by tex as f^2(x), not f(x)^2.
+;; This list is an exception, e.g. conjugate(x)^2.
+;; We use this list because tex-mexpt is also defined in stacktex40.lisp for earlier versions of Maxima.
+(defvar tex-mexpt-fnlist '(%sum %product %derivative %integrate %at $conjugate $texsub $lg $logbase %sqrt
+ %lsum %limit $pderivop $#pm#))
+
;; insert left-angle-brackets for mncexpt. a^<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
@@ -263,8 +263,8 @@
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...
+ ;; Unlike core Maxima we have alist of functions.
+ (not (member f tex-mexpt-fnlist :test #'eq))
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
(and (atom expon) (numberp expon) (> expon 0))))))
; f(x)^3 is ok, but not f(x)^-1, which could
@@ -274,14 +274,15 @@
(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 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))))
+ ((atom (cadr x)) (tex (cadr x) l nil lop (caar x)))
+ (t (tex (cadr x) (append l '("{")) '("}") lop (caar x))))
r (if (mmminusp (setq x (nformat (caddr x))))
;; the change in base-line makes parens unnecessary
(if nc
@@ -346,4 +347,148 @@
;; Define an "arrayp" function to check if we have a Maxima array.
(defmfun $arrayp (x) (and (not (atom x)) (cond ((member 'array (car x) :test #'eq) $true) (T $false))))
+;; *************************************************************************************************
+;; Added 19 Dec 2018.
+;; Based src/mformat.lisp
+
+;; Suppress warnings printed by mtell, e.g. by solve, rat and other functions.
+;; Use the Maxima variable stack_mtell_quiet.
+(defun mtell (&rest l) (cond ((eq $stack_mtell_quiet $true) (values)) (t (apply #'mformat nil l))));
+
+;; *************************************************************************************************
+;; Added 31 Oct 2019.
+;;
+;; catchable-syntax-error.lisp
+;; copyright 2019 by Robert Dodier
+;; I release this work under terms of the GNU General Public License v2
+
+;; Helper for MREAD-SYNERR.
+;; Adapted from local function PRINTER in built-in MREAD-SYNERR.
+
+(defun mread-synerr-printer (x)
+ (cond ((symbolp x)
+ (print-invert-case (stripdollar x)))
+ ((stringp x)
+ (maybe-invert-string-case x))
+ (t x)))
+
+;; Punt to Maxima function 'error' so that syntax errors can be caught by 'errcatch'.
+;; This definition replaces the built-in MREAD-SYNERR
+;; which throws to the top level of the interpreter in a way which cannot
+;; be intercepted by 'errcatch'.
+;;
+;; After a syntax error is detected, the global variable 'error'
+;; contains the error message (which is also printed on the console
+;; when the error occurs).
+;;
+;; Aside from punting to 'error', this implementation doesn't try to
+;; do anything else which the built-in MREAD-SYNERR does. In particular
+;; this implementation doesn't try to output any input-line information.
+
+(defun mread-synerr (format-string &rest l)
+ (let*
+ ((format-string-1 (concatenate 'string "syntax error: " format-string))
+ (format-string-args (mapcar #'mread-synerr-printer l))
+ (message-string (apply #'format nil format-string-1 format-string-args)))
+ (declare (special *parse-stream*))
+ (when (eql *parse-stream* *standard-input*)
+ (read-line *parse-stream* nil nil))
+ ($error message-string)))
+
+;; *************************************************************************************************
+;; Added 08 Jan 2020.
+;; Based src/grind.lisp
+
+;; Up the binding power of mminus, so that -(a/b) outputs exactly this way and not -a/b = (-a)/b.
+;; Subtle differences.
+
+;; In a maxima session type
+;; :lisp (defprop mminus 120. rbp);
+
+;; We provide just two specific functions here, and do not allow users to set an arbitrary binding power.
+
+;; *************************************************************************************************
+
+(defmspec $mminusbp120 (x)
+ (setq x (car x))
+ (defprop mminus 120. rbp)
+ (defprop mminus 120. lbp)
+ '$done
+)
+
+(defmspec $mminusbp100 (x)
+ (setq x (car x))
+ (defprop mminus 100. rbp)
+ (defprop mminus 100. lbp)
+ '$done
+)
+
+;; *************************************************************************************************
+;; Added 08 Jan 2020.
+;; Needed for %union, etc, where we don't display unions of just one item as unions.
+
+(defprop $%union tex-nary2 tex)
+(defprop $%union (" \\cup ") texsym)
+;; Sort out binding power of %union to display correctly.
+;; tex-support is defined in to_poly_solve_extra.lisp.
+(defprop $%union 114. tex-rbp)
+(defprop $%union 115. tex-lbp)
+
+(defprop $%intersection tex-nary2 tex)
+(defprop $%intersection (" \\cap ") texsym)
+(defprop $%intersection 114. tex-lbp)
+(defprop $%intersection 115. tex-rbp)
+
+
+(defun tex-nary2 (x l r)
+ (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
+ (cond ((null y) (tex-function x l r t)) ; this should not happen
+ ((null (cdr y)) (tex (car y) l r lop rop)) ; Single elements in the argument.
+ (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
+ ((null (cdr y)) (setq nl (append nl (tex (car y) l r lop rop))) nl)
+ (setq nl (append nl (tex (car y) l sym lop rop))
+ y (cdr y)
+ l nil))))))
+
+;; *************************************************************************************************
+;; Added 4 May 2023.
+;; Print all brackets with simp:false;
+
+;; This is WIP for printing brackets in (a+b)+c. Creates lots of other problems with unary minus.
+;; (defun tex (x l r lop rop)
+;; ;; x is the expression of interest; l is the list of strings to its
+;; ;; left, r to its right. lop and rop are the operators on the left
+;; ;; and right of x in the tree, and will determine if parens must
+;; ;; be inserted
+;; (setq x (nformat x))
+;; (cond ((atom x) (tex-atom x l r))
+;; ((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (>= (tex-lbp rop) (tex-rbp
+;; (caar x))))
+;; (tex-paren x l r))
+;; ;; special check needed because macsyma notates arrays peculiarly
+;; ((member 'array (cdar x) :test #'eq) (tex-array x l r))
+;; ;; dispatch for object-oriented tex-ifiying
+;; ((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
+;; (t (tex-function x l r nil))))
+
+;; *************************************************************************************************
+;; Added 27 June 2020.
+;; Localise some Maxmia-generated strings
+
+(defprop $true "\\mathbf{!BOOLTRUE!}" texword)
+(defprop $false "\\mathbf{!BOOLFALSE!}" texword)
+
+
+;; *************************************************************************************************
+;; Added 20 Feb 2022.
+;; Remove %_C and %_E for display purposes. The Maxima function %_ce_rem is defined in utils.mac
+
+(defmfun $tex1 (x) (reduce #'strcat (tex ($%_ce_rem x) nil nil 'mparen 'mparen)))
+
+;; *************************************************************************************************
+;; Added 30 May 2022.
+;; Allow Maxima to interigate the texword database directly, for words or function names.
+;; Copied directly from tex-atom.
+(defmfun $get_texword (x) (or (get x 'texword) (get (get x 'reversealias) 'texword)))
+(defmfun $get_texsym (x) (car (or (get x 'texsym) (get x 'strsym) (get x 'dissym) (stripdollar x))))
diff --git a/stack/2017121800/maxima/stacktex40.lisp b/stack/2023102700/maxima/stacktex40.lisp
similarity index 80%
rename from stack/2017121800/maxima/stacktex40.lisp
rename to stack/2023102700/maxima/stacktex40.lisp
index 2f688179b2c7d0573e3db8a3caef343746f7fbae..ebe670d0e1548a47332cc6716c4bf9436f8c1ecf 100644
--- a/stack/2017121800/maxima/stacktex40.lisp
+++ b/stack/2023102700/maxima/stacktex40.lisp
@@ -29,8 +29,7 @@
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...
+ (not (member f tex-mexpt-fnlist :test #'eq))
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
(and (atom expon) (numberp expon) (> expon 0))))))
; f(x)^3 is ok, but not f(x)^-1, which could
@@ -47,7 +46,8 @@
(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))))
+ ((atom (cadr x)) (tex (cadr x) l nil lop (caar x)))
+ (t (tex (cadr x) (append l '("{")) '("}") lop (caar x))))
r (if (mmminusp (setq x (nformat (caddr x))))
;; the change in base-line makes parens unnecessary
(if nc
@@ -60,9 +60,39 @@
(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
diff --git a/stack/2017121800/maxima/stackunits.mac b/stack/2023102700/maxima/stackunits.mac
similarity index 77%
rename from stack/2017121800/maxima/stackunits.mac
rename to stack/2023102700/maxima/stackunits.mac
index eb01d04b72e678f5887fd43fba609845a29ce870..a63abfac2365996aaf83c9bdfc87fdaddde3ec85 100644
--- a/stack/2017121800/maxima/stackunits.mac
+++ b/stack/2023102700/maxima/stackunits.mac
@@ -26,8 +26,8 @@
/* 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
+/* This code is commented out as these lists are now defined in the main code in stack/cas/casstring.units.php
+ which are copied over to maximalocal.mac by the install scripts. This ensures exactly the
same collections of units are available in PHP and this Maxima code.
stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y],
@@ -41,28 +41,30 @@
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)$
+/* 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)^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)^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)$
+
+unitsp(ex) := featurep(ex, 'units)$
/* List all variables *not* considered to be not units. */
listofnonunits(ex) := block(
- if not(member(units, features)) then
+ 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
+ if not(member('units, features)) then
stack_unit_si_declare(true),
sublist(listofvars(ex), unitsp)
)$
@@ -73,22 +75,22 @@ listofunits(ex) := block(
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); */
+ /* Check with member('units, features); */
declare(units, feature),
simp:true,
- for ui:1 thru length(stack_unit_si_unit_code) do
+ for ui:1 thru length(stack_unit_si_unit_code) do
(
- for pfi:1 thru length(stack_unit_si_prefix_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('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])
+ 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])
+ apply('declare, [stack_unit_other_unit_code[ui], 'units])
)
)$
@@ -97,18 +99,20 @@ stack_unit_si_to_si_base(expression) := block([ui, pfi, ex, workex, oldsimp],
oldsimp:simp,
simp:false,
ex:stackunits_make(expression),
+ /* Remove intert dp/df display functions at this point. */
+ ex:ev(ex, displaydp=lambda([a,b],a), displaysf=lambda([a,b],a)),
workex:stack_units_units(ex),
if debug then (print("stack_unit_si_to_si_base: working with the following."), print(ex), print(workex)),
/* If we don't have units there is nothing to do. */
if is(workex=NULLUNITS) then return(expression),
exop:safe_op(expression),
simp:true,
- for ui:1 thru length(stack_unit_other_unit_code) do
+ 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
+ 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)
),
@@ -118,7 +122,7 @@ stack_unit_si_to_si_base(expression) := block([ui, pfi, ex, workex, oldsimp],
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. */
+ /* Return the expression with the operator it started with. */
simp:oldsimp,
if not(safe_op(expression) = "stackunits") then
workex:stackunits_to_product(workex),
@@ -129,11 +133,11 @@ stack_unit_si_present(value,target) := block([conversionfactor, va, vb, simp, be
simp:true,
bestc:9000000,
if listp(target) then (
- for ii:1 thru length(target) do
+ 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))
+ 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)),
@@ -158,7 +162,7 @@ stack_unit_si_present(value,target) := block([conversionfactor, va, vb, simp, be
va:va*conversionfactor,
vb:stack_units_units(stackunits_make(target)),
if ii
- then error("Units presentation requires compatible units.")
+ then error("Units presentation requires compatible units.")
else return(stackunits(va,vb))
)
)$
@@ -166,7 +170,7 @@ stack_unit_si_present(value,target) := block([conversionfactor, va, vb, simp, be
/* 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
+ if not(member('units, features)) then
stack_unit_si_declare(true),
oldsimp:simp,
simp:false,
@@ -177,13 +181,13 @@ stackunits_make(ex) := block([oldsimp, exn, exu, exl],
return(stackunits(NULLNUM, ex)),
if safe_op(ex)="stackunits" then
return(ex),
- if is_simp(op(ex)="+-") then return(block([numa,numb],
+ if is_simp(op(ex)=STACKpmOPT) then return(block([numa,numb],
if length(args(ex))=1 then
(
numa:NULLNUM,
numb:first(args(ex))
)
- else
+ else
(
numa:first(args(ex)),
numb:second(args(ex))
@@ -200,18 +204,22 @@ stackunits_make(ex) := block([oldsimp, exn, exu, exl],
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
+ /* 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)="nounpow") then
+ exn:[exn] elseif not(is_simp(op(exn)="nounmul")) 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
+ if is_simp(emptyp(exn)) then
exn:[NULLNUM],
/* Flag up if we genuinely have no units. */
- if is_simp(emptyp(exu)) then
+ if is_simp(emptyp(exu)) then
exu:[NULLUNITS],
/* Transform (a^2)^-1 to a^(-2), for the units. */
exu:maplist(unary_minus_remove, exu),
@@ -221,14 +229,14 @@ stackunits_make(ex) := block([oldsimp, exn, exu, exl],
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
- (
+ if is(first(exn) = UNARY_MINUS) then block(
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)),
+ ),
+ if length(exn)=1 then exn:first(exn) else exn:apply("nounmul", exn),
+ if length(exu)=1 then exu:first(exu) else exu:apply("nounmul", exu),
+ if (debug) then (print("stackunits_make: (3) reformulated numbers as "), print(exn)),
+ if (debug) then (print("stackunits_make: (3) reformulated units as "), print(exu)),
verb_arith(stackunits(exn, exu))
)$
@@ -239,9 +247,9 @@ stack_units_split(ex) := args(stackunits_make(ex))$
stackunits_to_product(ex) := block(
if not(safe_op(ex) = "stackunits") then
return(ex),
- if stack_units_units(ex) = NULLUNITS then
+ if stack_units_units(ex) = NULLUNITS then
return(stack_units_nums(ex)),
- if stack_units_nums(ex) = NULLNUM then
+ if stack_units_nums(ex) = NULLNUM then
return(stack_units_units(ex)),
apply("*", args(ex))
)$
@@ -252,18 +260,18 @@ stackunits_make_p(ex) := block(
return(true),
if emptyp(listofvars(ex)) then
return(true),
- if simp_numberp(ev(float(verb_arith(ex)), simp)) then
+ if simp_complex_number_p(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 length(ex)=1 and safe_op(first(ex))="nounpow" 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)))]),
+ if safe_op(second(ex))="nounpow" and is(second(args(second(ex)))=-1) then return([first(ex)/first(args(second(ex)))]),
ex
)$
@@ -324,23 +332,26 @@ stack_units_errp(ex) := block(
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.")
+ 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
+ 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
+ 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.*/
@@ -359,7 +370,7 @@ stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:
/* 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
+ 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"))
@@ -372,23 +383,21 @@ stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:
),
/* Check if the student has added in error bounds. */
- if stack_units_errp(SAU) then
+ 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
- (
+ if fracdisp = "inline" then block(
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))
+ 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)
)$
@@ -396,11 +405,15 @@ stack_validate_units(expr, LowestTerms, TAns, fracdisp, fltfmt) := block( [simp:
stackunitstex(ex) := block ([a, b, c, astr],
a:first(args(ex)),
b:second(args(ex)),
+ if scientific_notationp(a) then make_multsgn("cross"),
astr:tex1(a),
+ if scientific_notationp(a) then make_multsgn("blank"),
+ 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(safe_op(b)="/") then
if (is(first(args(b))=1)) then return(sconcat(astr,"\\times ",tex1(b))),
/* Otherwise.... */
sconcat(astr,"\\, ",tex1(b))
@@ -410,30 +423,34 @@ 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")$
+ATUnits(SA, SB, SO, SR) := ATUnitsFun(SA, SB, SO, SR, false, "SigFigs")$
+ATUnitsSigFigs(SA, SB, SO, SR) := ATUnitsFun(SA, SB, SO, SR, false, "SigFigs")$
+ATUnitsStrict(SA, SB, SO, SR) := ATUnitsFun(SA, SB, SO, SR, true, "SigFigs")$
+ATUnitsStrictSigFigs(SA, SB, SO, SR) := ATUnitsFun(SA, SB, SO, SR, true, "SigFigs")$
+ATUnitsSigFigs_CASSigFigsWrapper(SA, SB, SO, SR, strict) := ATUnitsFun(SA, SB, SO, SR, strict, "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],
+ATUnitsFun(SA, SB, SO, SR, strictp, numtest) := block([validity, rawmk, sb, ansnote,
+ SAU, SBU, SOU, SAU1, SBU1, SOU1, 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
+ if (is(_EC(errcatch(SAA:ev(SA, simp, nouns)), "") = false)) then
return([false, false, StackAddNote("", "ATUnits_STACKERROR_SAns"), ""]),
- SBB:errcatch(ev(SB, simp, nouns)),
- if (is_simp(SBB = [STACKERROR]) or is_simp(SBB = [])) then
+ if (is(_EC(errcatch(SBB:ev(SB, simp, nouns)), "") = false)) then
return([false, false, StackAddNote("", "ATUnits_STACKERROR_TAns"), ""]),
- SOO:errcatch(ev(SO, simp, nouns)),
- if (is_simp(SOO = [STACKERROR]) or is_simp(SOO = [])) then
+ if (is(_EC(errcatch(SOO:ev(SO, simp, nouns)), "") = false)) then
return([false, false, StackAddNote("", "ATUnits_STACKERROR_Opt"), ""]),
+ if (is(_EC(errcatch(SRR:ev(SR, simp, nouns)), "") = false)) then
+ return([false, false, StackAddNote("", "ATUnits_STACKERROR_Raw"), ""]),
- ol:SO,
+ ol:SO,
/* SA should be only an expression. */
if not(expressionp(SA)) then
@@ -448,13 +465,23 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
return([false, false, StackAddNote("", "ATUnits_SA_no_units"), StackAddFeedback("", "ATUnits_SA_no_units")]),
/* Load and setup units. */
- if not(member(units, features)) then
+ 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)),
+ /* If the teacher has not supplied numerical information then it is assumed to be 1.0.
+ The teacher's answer could well be the result of a calculation in which 1.0*units -> units. */
+ if stack_units_nums(SBU) = NULLNUM then
+ SBU:stackunits_make(1.0*SB),
+ SOU:stackunits_make(SO),
+
+ /* If the teacher uses units in the option then they must be identical to the units in the teacher's answer. */
+ if (numtest = "Absolute") and not(is_simp(stack_units_units(SOU) = NULLUNITS)) and not(stack_units_units(SBU) = stack_units_units(SOU)) then
+ (print("TEST_FAILED"), return(StackBasicReturn(false, false, "ATUnits_SO_wrong_units"))),
+
+ if (debug) then (print("ATUnitsFun: Initial stackunits_make gives: "), print(SAU), print(SBU), print(SOU)),
/* The teacher must supply some units, otherwise the test will fail. */
if is_simp(stack_units_units(SBU) = NULLUNITS) then
@@ -464,7 +491,7 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
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. */
+ /* 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
@@ -473,13 +500,17 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
/* 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 (debug) then (print("ATUnitsFun: call to 1st numerical test with data: "), print(SAU1), print(SBU1), print([ol, SOU])),
+
if (numtest = "SigFigs") then
- ret1: ATNumSigFigs(SAU1, SBU1, ol)
- else if (numtest = "Absolute") then
- ret1: ATNumAbsolute(SAU1, SBU1, ol)
+ /* Sigfigs test should not use units in the option. */
+ ret1: ATNumSigFigs(SAU1, SBU1, SO, SR)
else if (numtest = "Relative") then
- ret1: ATNumRelative(SAU1, SBU1, ol)
+ 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)),
@@ -490,33 +521,42 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
/* 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.
+ /* 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),
- if (debug) then (print("ATUnits: results of convertion to base units."), print(SAU), print(SBU)),
+ 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 = "Absolute") then
- ret2: ATNumAbsolute(SAU1, SBU1, ol)
+ ret2: ATNumSigFigs(SAU1, SBU1, ol, SR)
else if (numtest = "Relative") then
ret2: ATNumRelative(SAU1, SBU1, ol)
- else
+ 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
+ if not(ret2[1]) then
return([ret2[1], ret2[2], StackAddNote(ret2[3], "ATUnits_second_numerial_test_failed"), ret2[4]]),
/* Check for incompatible units. */
@@ -534,13 +574,13 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
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
+ 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)))),
+ ansnote:StackAddNote(ret2[3], sconcat("ATUnits_compatible_units ", string(ev(stack_units_units(SBU), simp)))),
fb:ret2[4],
/* Is the numerical answer correct? */
@@ -555,7 +595,7 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
/* 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("", sconcat("ATUnits_compatible_units ", string(ev(stack_units_units(SBU), simp)))),
ansnote:StackAddNote(ansnote, "ATUnits_correct_numerical"),
fb:StackAddFeedback("", "ATUnits_correct_numerical")
),
@@ -565,6 +605,5 @@ ATUnitsFun(SA, SB, SO, strictp, numtest) := block([validity, rawmk, sb, ansnote,
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/2023102700/maxima/to_poly_solve_extra_5.38.1.lisp
similarity index 100%
rename from stack/2017121800/maxima/to_poly_solve_extra_5.38.1.lisp
rename to stack/2023102700/maxima/to_poly_solve_extra_5.38.1.lisp
diff --git a/stack/2023102700/maxima/trigrat.lisp b/stack/2023102700/maxima/trigrat.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..868240b224cf8214914b22d84eef0e388235caa0
--- /dev/null
+++ b/stack/2023102700/maxima/trigrat.lisp
@@ -0,0 +1,56 @@
+(in-package :maxima)
+
+(defun $listofei (e )
+ (declare (special $d2% $lg% $lexp%))
+ (setq $d2% (copy-tree (car e)))
+ (setq $lg% ())
+ (setq $lexp% ())
+ (do ((lvar (caddr $d2%) (cdr lvar))
+ (lg% (cadddr $d2%) (cdr lg%))
+ (var))
+ ((null lvar)(setq $lg% (cons '(mlist) $lg%))
+ (setq $lexp% (cons '(mlist) $lexp%))
+ (setq $d2% (cons $d2% (cdr e))) )
+ (setq var (car lvar))
+ (cond ((and (mexptp var)
+ (equal (cadr var) '$%e)
+; (mtimesp (caddr var))
+; (eq (cadr (caddr var)) '$%i)
+ ;; Check that we have a factor of %i. This test includes
+ ;; cases like %i, and %i*x/2, which we get for e.g.
+ ;; sin(1) and sin(x/2).
+ (eq '$%i (cdr (partition (if (atom (caddr var))
+ (list '(mtimes)(caddr var))
+ (caddr var))
+ '$%i 1))))
+ (setq $lexp% (cons var $lexp%))
+ (setq var (symbolconc "$_" (car lg%)))
+ (setq $lg% (cons var $lg%))
+ (rplaca lvar var)))))
+
+#$trigrat_equationp (e%) :=
+ not atom (e%)
+ and member (op (e%), ["=", "#", "<", "<=", ">=", ">"])$
+
+#$trigrat(exp):=
+ if matrixp (exp) or listp (exp) or setp (exp) or trigrat_equationp (exp)
+ then map (trigrat, exp)
+ else block([e%,n%,d%,lg%,f%,lexp%,ls,d2%,l2%,alg,gcd1],
+ alg:algebraic,gcd1:gcd,
+ algebraic:true,gcd:subres,
+ e%: rat(ratsimp(expand(exponentialize(exp)))),
+ n%:num(e%),d%:denom(e%),
+ listofei(d%),
+ l2%:map(lambda([u%,v%],u%^((hipow(d2%,v%)+lopow(d2%,v%))/2)),
+ lexp%,lg%),
+ f%:if length(lexp%)=0 then 1
+ else if length(lexp%)=1 then part(l2%,1)
+ else apply("*",l2%),
+ n%:rectform(ratexpand(n%/f%)),
+ d%:rectform(ratexpand(d%/f%)),
+ e%:ratsimp(n%/d%,%i),
+ algebraic:alg,gcd:gcd1,
+ e%)$
+
+; written by D. Lazard, august 1988
+; modified by C. Sangwin, November 2020.
\ No newline at end of file
diff --git a/stack/2017121800/maxima/unittests_load.mac b/stack/2023102700/maxima/unittests_load.mac
similarity index 89%
rename from stack/2017121800/maxima/unittests_load.mac
rename to stack/2023102700/maxima/unittests_load.mac
index f124a05080e9a19066059a4dfe03ed92aeb116e6..e60a81e371f5eed3873eb54f123b9e2b64e655b3 100644
--- a/stack/2017121800/maxima/unittests_load.mac
+++ b/stack/2023102700/maxima/unittests_load.mac
@@ -6,12 +6,13 @@
/* 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:"/home/sangwinc/Documents/linuxnotes/moodle27.mac"$
-LOADDIR:"/var/data/moodle_equiv/equiv/stack/stackmaxima.mac"$
+
+LOADDIR:"stackmaxima.mac"$
print("Working from: ")$
print(LOADDIR)$
-/*load(LOADDIR)$/*
+load(LOADDIR)$
no_fails:0$ all_pass:true$
@@ -34,5 +35,3 @@ print(STB);
print("************ simp is false.");
print(SFF);
print(SFB);
-
-
diff --git a/stack/2023102700/maxima/utils.mac b/stack/2023102700/maxima/utils.mac
new file mode 100644
index 0000000000000000000000000000000000000000..e471af0d9cd261df27bec7de90529c24a4754ab7
--- /dev/null
+++ b/stack/2023102700/maxima/utils.mac
@@ -0,0 +1,320 @@
+/* Misc functions for dealing with Maxima and the other tools. */
+
+/* Takes a Maxima string and converts everything that could cause trouble in a HTML/XML document to entities.
+ Note that if the string already contains entities even them are converted and thus broken. */
+
+str_to_html_char(c) := if c = "&" then "&"
+ else if c = "'" then "'" /* ' is for XHTML, we need to still deal with HTML. */
+ else if c = "\"" then """
+ else if c = ">" then ">"
+ else if c = "<" then "<"
+ else c$
+str_to_html(string_to_escape) := simplode(map(str_to_html_char, charlist(string_to_escape)))$
+
+/* Same for generating ECMAScript strings. */
+str_to_js_char(c) := if c = "\\" then "\\\\"
+ else if c = "\"" then "\\\""
+ else if c = "'" then "\\'"
+ else if c = ascii( 8) then "\\b" else if c = ascii( 9) then "\\t"
+ else if c = ascii(10) then "\\n" else if c = ascii(12) then "\\f"
+ else if c = ascii(13) then "\\r" else c$
+str_to_js(string_to_escape) := simplode(map(str_to_js_char, charlist(string_to_escape)))$
+
+/* Defintion of characters to escape in Markdown. */
+md_escapes(c) := if c = "\\" then "\\\\"
+ else if c = "*" then "\\*"
+ else if c = "|" then "|" /* The pipe neds to be converted in case one injects into a table. Mere escaping may not be enough there. */
+ else if c = "`" then "`" /* The logic of backtick escaping is not local so we do an entity conversion just in case. */
+ else if c = "_" then "\\_"
+ else if c = "{" then "\\{"
+ else if c = "}" then "\\}"
+ else if c = "[" then "\\["
+ else if c = "]" then "\\]"
+ else if c = "(" then "\\("
+ else if c = ")" then "\\)"
+ else if c = "<" then "\\<"
+ else if c = ">" then "\\>"
+ else if c = "#" then "\\#"
+ else if c = "+" then "\\+"
+ else if c = "-" then "\\-"
+ else if c = "." then "\\."
+ else if c = "!" then "\\!"
+ else c$
+
+str_to_md(string_to_escape) := simplode(map(md_escapes,charlist(string_to_escape)))$
+
+/* Split a Maxima timestamp (seconds from Jan 1 1900) to numbers representing a date.
+ The returned list consists of integers [year, month, day, weekday] where Sunday is 7 (ISO 8601). */
+time_to_date(seconds) := block([y,m,d,S],
+ S: split(first(split(timedate(seconds), " ")), "-"),
+ y: parse_string(S[1]),
+ m: parse_string(S[2]),
+ d: parse_string(S[3]),
+ return([y, m, d, day_for_date(y, m, d)])
+)$
+
+day_for_date(year, month, day) := block([reference, tmp, d],
+ reference: parse_timedate("1900-01-08 12:00:00"), /* That is a Monday, the 1st was also but time-zones can cause trouble here and we need some space for them. */
+ tmp: parse_timedate(sconcat(year, "-", if month < 10 then sconcat("0", month) else month, "-", if day < 10 then sconcat("0", day) else day, " 12:00:00")),
+ d: floor((tmp - reference)/(24*60*60) + 1/2), /* There are these things called leap seconds let's hope they do not add up to 10 hours to one direction at any point during our lifetimes. */
+ while d < 0 do d: d + 7000, /* Considering that Maximas timedate system breaks if given dates from the 19th century this is good enough. */
+ d: 1 + mod(d,7),
+ return(d)
+)$
+
+/* Generates a continuous list of dates between two dates, the second date is not included in the list but the first is. */
+date_list(yearA, monthA, dayA, yearB, monthB, dayB) := block([y, m, d, wd, S, R, c, et, rev],
+ rev: false,
+ if yearA+(monthA/12)+(dayA/366) > yearB+(monthB/12)+(dayB/366) then
+ rev: true,
+ if yearA = yearB and monthA = monthB and dayA = dayB then
+ return([]),
+ c: parse_timedate(sconcat(yearA, "-", if monthA < 10 then sconcat("0", monthA) else monthA, "-", if dayA < 10 then sconcat("0", dayA) else dayA, " 12:00:00")),
+ et: parse_timedate(sconcat(yearB, "-", if monthB < 10 then sconcat("0", monthB) else monthB, "-", if dayB < 10 then sconcat("0", dayB) else dayB, " 12:00:00")),
+ R: [time_to_date(c)],
+ c: if rev then c - 24*60*60 else c + 24*60*60,
+ while (c < et and not rev) or (rev and c > et) do (
+ S: split(first(split(timedate(c), " ")), "-"),
+ y: parse_string(S[1]),
+ m: parse_string(S[2]),
+ d: parse_string(S[3]),
+ wd: if not rev then last(last(R)) + 1 else last(last(R)) - 1,
+ if wd > 7 then wd: 1,
+ if wd = 0 then wd: 7,
+ R: append(R, [[y, m, d, wd]]),
+ c: if rev then c - 24*60*60 else c + 24*60*60
+ ),
+ /* Due to DST and other such fun things that iteration can go over. */
+ S: last(R),
+ if first(S) = yearB and second(S) = monthB and third(S) = dayB then
+ R: rest(R, -1),
+ return(R)
+)$
+
+/* Finds the number of significant digits in the first numeric part of a given string representation of an expression. Pretty much the same logic as the original PHP version stack_utils::decimal_digits. */
+sig_figs_from_str(strexp) := block([leadingzeros,indefinitezeros,trailingzeros,meaningfulldigits,decimalplaces,infrontofdecimaldeparator,scientificnotation,seennumbers,c,i,r,simp],
+ /* Plenty of countters so needs simp */
+ simp: true,
+ leadingzeros: 0,
+ indefinitezeros: 0,
+ trailingzeros: 0,
+ meaningfulldigits: 0,
+ decimalplaces: 0,
+ infrontofdecimaldeparator: true,
+ scientificnotation: false,
+ seennumbers: false,
+
+ /* If this is an empty string one probably has trouble. */
+ if (slength(strim(" ",strexp)) = 0) then
+ return(["stack_map",
+ ["lowerbound", 0],
+ ["upperbound", 0],
+ ["decimalplaces", 0],
+ ["fltfmt", "~a"]]),
+
+
+ i: 1,
+ /* First eat the stuff in front of of the number if it exists */
+ while i <= slength(strexp) do (
+ c: charat(strexp, i),
+
+ if c = "." then (
+ infrontofdecimaldeparator: false,
+ meaningfulldigits: meaningfulldigits + indefinitezeros,
+ indefinitezeros: 0,
+ leadingzeros: 0,
+ seennumbers: true
+ ) else if c = "0" then (
+ leadingzeros: 1,
+ seennumbers: true
+ ) else if member(c,["1","2","3","4","5","6","7","8","9"]) then (
+ meaningfulldigits: meaningfulldigits + indefinitezeros + 1,
+ indefinitezeros: 0,
+ seennumbers: true
+ ),
+ i: i + 1,
+
+ if seennumbers then return(0)
+ ),
+
+ /* Now we are safely in the number hopefully there is a number... */
+ while i <= slength(strexp) do (
+ c: charat(strexp, i),
+
+ if infrontofdecimaldeparator = false and member(c,["0","1","2","3","4","5","6","7","8","9"]) then (
+ decimalplaces: decimalplaces + 1
+ ),
+ if c = "e" or c = "E" then (
+ if (meaningfulldigits + leadingzeros + indefinitezeros) > 0 then (
+ scientificnotation: true
+ )
+ ),
+
+ if c = "0" then (
+ if meaningfulldigits = 0 then (
+ leadingzeros: leadingzeros + 1
+ ) else if infrontofdecimaldeparator then (
+ indefinitezeros: indefinitezeros + 1
+ ) else if meaningfulldigits > 0 then (
+ meaningfulldigits: meaningfulldigits + 1 + indefinitezeros + trailingzeros,
+ trailingzeros: 0,
+ indefinitezeros: 0
+ ) else (
+ trailingzeros: trailingzeros + 1
+ )
+ ) else if c = "." and infrontofdecimaldeparator then (
+ infrontofdecimaldeparator: false,
+ meaningfulldigits: meaningfulldigits + indefinitezeros,
+ indefinitezeros: 0,
+ leadingzeros: 0
+ ) else if member(c,["1","2","3","4","5","6","7","8","9"]) then (
+ meaningfulldigits: meaningfulldigits + indefinitezeros + 1,
+ indefinitezeros: 0
+ ) else (
+ if (meaningfulldigits + leadingzeros + indefinitezeros) > 0 then (
+ /* Stop only if we have seens something like a number. */
+ return(0)
+ )
+ ),
+ i: i + 1
+ ),
+
+ r: ["stack_map",
+ ["lowerbound", 0],
+ ["upperbound", 0],
+ ["decimalplaces", decimalplaces],
+ ["fltfmt", "~a"]],
+
+ if is(meaningfulldigits = 0) then (
+ r: stackmap_set(r, "lowerbound", max(1, leadingzeros)),
+ r: stackmap_set(r, "upperbound", max(1, leadingzeros))
+ ) else if is(infrontofdecimaldeparator=false) then (
+ r: stackmap_set(r, "lowerbound", meaningfulldigits),
+ r: stackmap_set(r, "upperbound", meaningfulldigits)
+ ) else (
+ r: stackmap_set(r, "lowerbound", meaningfulldigits),
+ r: stackmap_set(r, "upperbound", meaningfulldigits + indefinitezeros)
+ ),
+
+ if is(decimalplaces > 0) then (
+ r: stackmap_set(r, "fltfmt", sconcat("~,", decimalplaces, "f"))
+ ),
+ if is(scientificnotation = true) then (
+ if is(stackmap_get(r, "lowerbound") > 1) then (
+ r: stackmap_set(r, "fltfmt", sconcat("~.", stackmap_get(r, "upperbound"), "e"))
+ ) else (
+ r: stackmap_set(r, "fltfmt", "~e")
+ )
+ ),
+ return(r)
+)$
+
+
+
+FORBIDDEN_SYMBOLS_SET: {"%th", "adapth_depth", "alias", "aliases", "alphabetic", "appendfile",
+ "apropos", "assume_external_byte_order", "backtrace", "batch", "barsplot", "batchload",
+ "boxchar", "boxplot", "bug_report", "build_info", "catch", "chdir", "close", "closefile",
+ "compfile", "compile", "compile_file", "concat", "current_let_rule_package",
+ "data_file_name", "deactivate", "debugmode", "define", "define_variable", "del_cmd", "demo",
+ "dependencies", "describe", "dimacs_export", "dimacs_import", "entermatrix",
+ "error", "error_size", "error_syms", "errormsg", "eval_string", "example",
+ "feature", "featurep", "features", "file_name", "file_output_append", "file_search",
+ "file_search_demo", "file_search_lisp", "file_search_maxima", "file_search_tests",
+ "file_search_usage", "file_type", "filename_merge", "flength", "FORBIDDEN_SYMBOLS_SET",
+ "fortindent", "fortran", "fortspaces", "fposition", "freshline", "functions",
+ "fundef", "funmake", "grind", "gnuplot_cmd", "gnuplot_file_name", "gnuplot_out_file",
+ "gnuplot_preamble", "gnuplot_ps_term_command", "gnuplot_term", "inchar", "infeval",
+ "infolists", "kill", "killcontext", "labels", "leftjust", "ldisp", "ldisplay",
+ "lisp", "linechar", "linel", "linenum", "linsolvewarn", "load", "load_pathname",
+ "loadfile", "loadprint", "macroexpand", "macroexpand1", "macroexpansion", "macros",
+ "manual_demo", "maxima_tempdir", "maxima_userdir", "mkdir", "multiplot_mode", "myoptions",
+ "newline", "nolabels", "opena", "opena_binary", "openr", "openr_binary", "openw",
+ "openw_binary", "outchar", "packagefile", "parse_string", "pathname_directory",
+ "pathname_name", "pathname_type", "pickapart", "piece", "playback", "plotdf", "print",
+ "print_graph", "printf", "printfile", "prompt", "psfile", "quit", "read", "read_array",
+ "read_binary_array", "read_binary_list", "read_binary_matrix", "read_hashed_array",
+ "read_list", "read_matrix", "read_nested_list", "read_xpm", "readline", "readonly",
+ "refcheck", "rembox", "remvalue", "remfunction", "reset", "rmxchar", "room",
+ "run_testsuite", "run_viewer", "save", "savedef", "scatterplot", "starplot",
+ "stemplot", "set_plot_option", "setup_autoload", "setcheck", "setcheckbreak",
+ "setval", "showtime", "sparse6_export", "sparse6_import", "splice", "sprint", "status",
+ "stringout", "supcontext", "system", "tcl_output", "terminal", "tex", "testsuite_files",
+ "throw", "time", "timer", "timer_devalue", "timer_info", "to_lisp", "trace", "trace_options",
+ "transcompile", "translate", "translate_file", "transrun", "ttyoff", "untimer",
+ "untrace", "user_preamble", "values", "with_stdout", "write_binary_data", "write_data", "writefile",
+ "%_ce_rem"
+}$
+
+/* This is the allowed version of concat that blocks the possibility to construct certain dangerous things. */
+vconcat([ex]) := block([tmp],
+ tmp: apply(concat, ex),
+ if symbolp(tmp) and elementp(sconcat(tmp), FORBIDDEN_SYMBOLS_SET) then
+ error(sconcat("concat: '", tmp, "' is a forbidden symbol and cannot be constructed.")),
+ return(tmp)
+)$
+
+all_ops(%_expr) := block([%_edge, %_next_edge, %_tmp, %_op, %_result],
+ /* Returns a list of all the operators and functions
+ in use in the expression. Turn it to a bag if you need
+ the counts or a set if only the existence matters. */
+ %_next_edge : [%_expr],
+ %_result : [],
+ while length(%_next_edge) > 0 do (
+ %_edge : %_next_edge,
+ %_next_edge : [],
+ for %_tmp in %_edge do (
+ %_op : safe_op(%_tmp),
+ if not (%_op = "") then (
+ %_result : append(%_result, [%_op]),
+ %_next_edge : append(%_next_edge, args(%_tmp))
+ )
+ )
+ ),
+ %_result
+)$
+
+%_C(%_id) := block([simp], simp:true,
+ if elementp(sconcat(%_id), FORBIDDEN_SYMBOLS_SET) then (
+ error(sconcat("Attempt to call forbidden function detected: ", %_id))
+ )
+)$
+
+%_E(%_expr) := block([simp,%_tmp],
+ simp: false,
+ /* Also forbid these inside this context. */
+ %_tmp: intersection(union(FORBIDDEN_SYMBOLS_SET,{"map", "subst", "at", "apply", "fullmap", "fullmapl", "funmake", "maplist", "matrixmap", "outermap", "scanmap", ":", ":="}), setify(all_ops(%_expr))),
+ if cardinality(%_tmp) > 0 then (
+ error(sconcat("Attempt to evaluate a constructed: ", simplode(listify(%_tmp), ", ")))
+ ),
+ %_expr
+)$
+
+/* Remove blocks starting with %_C and %_E from the expression. Only permitted for display functions, e.g. tex1.*/
+%_ce_rem(ex) := block([ex2,simp],
+ /* We need to assume simp:false, so unevaluated/simplified expressions don't potentially throw errors here. */
+ simp:false,
+ /* The case below is atoms and things like m[k], which should not be processed further. */
+ if safe_op(ex) = "" then return(ex),
+ if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_C" then return(%_ce_rem(second(args(ex)))),
+ if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_E" then return(%_ce_rem(second(args(ex)))),
+ /* Rather subtle order of evaluation issue. */
+ ex2:args(ex),
+ ex2:map(%_ce_rem, ex2),
+ substpart(op(ex), ex2, 0)
+)$
+/* We need to compile %_CE_rem so that it is available to lisp as a lisp function. */
+compile(%_ce_rem)$
+
+/* Remove %C_ and %E from expessions, but evaluate them now. I.e. expedite the checks. */
+%_ce_expedite(ex) := block([ex2,simp],
+ /* We need to assume simp:false, so unevaluated/simplified expressions don't potentially throw errors here. */
+ simp:false,
+ /* The case below is atoms and things like m[k], which should not be processed further. */
+ if safe_op(ex) = "" then return(ex),
+ if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_C" then (ev(first(args(ex))), return(%_ce_rem(second(args(ex))))),
+ if safe_op(ex) = "(" and safe_op(first(args(ex))) = "%_E" then (ev(first(args(ex))), return(%_ce_rem(second(args(ex))))),
+ /* Rather subtle order of evaluation issue. */
+ ex2:args(ex),
+ ex2:map(%_ce_expedite, ex2),
+ substpart(op(ex), ex2, 0)
+)$
diff --git a/stack/2023102700/maxima/validator.mac b/stack/2023102700/maxima/validator.mac
new file mode 100644
index 0000000000000000000000000000000000000000..0f56f90d90ccac24592ffb9510da788258781342
--- /dev/null
+++ b/stack/2023102700/maxima/validator.mac
@@ -0,0 +1,240 @@
+/* Author Chris Sangwin
+ University of Edinburgh
+ Copyright (C) 2023 Chris Sangwin
+
+ This program is free software: you can redistribute it or modify
+ it under the terms of the GNU General Public License version two.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* ******************************************* */
+/* Validate an expression */
+/* ******************************************* */
+
+/* List of variables, without some specific tokens in. */
+stack_validate_listofvars(_exunlikelyatom) := block([lvars],
+ lvars:ev(setify(listofvars(_exunlikelyatom)), simp),
+ lvars:ev(setdifference(lvars,{null, QMCHAR, EMPTYANSWER}), simp),
+ lvars:ev(sort(listify(lvars)), simp)
+)$
+
+stack_validate_checkvars(sexpr, texpr, chkopt) := block([%_sansvar,%_tansvar,%_extras,%_errstr],
+ if is(chkopt = 0) then return(""),
+ %_sansvar:setify(stack_validate_listofvars(sexpr)),
+ %_tansvar:setify(stack_validate_listofvars(texpr)),
+ %_extras: setdifference(%_sansvar, %_tansvar),
+ %_missing:setdifference(%_tansvar, %_sansvar),
+ %_errstr: "",
+ if ev(length(%_extras) > 0 and mod(chkopt, 2) = 1,simp) then
+ %_errstr:StackAddFeedback(%_errstr, "ValidateVarsSpurious" , stack_disp_comma_separate(listify(%_extras))),
+ if ev(length(%_missing) > 0 and (mod(chkopt, 4)-mod(chkopt, 2)) = 2, simp) then
+ %_errstr:StackAddFeedback(%_errstr, "ValidateVarsMissing" , stack_disp_comma_separate(listify(%_missing))),
+ /* A non-empty string means invalid. */
+ return(%_errstr)
+)$
+
+stack_validate(expr, LowestTerms, TAns, fltfmt, chkopt) := block([simp:false, exs, SameType, fvs, fvs1, fvs2, chkvars],
+ /* 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"),
+ return(false)
+ ),
+ if length(expr)#1 then print(StackAddFeedback("", "CommaError", string(expr), string(setify(expr)))),
+ expr: first(expr),
+ /* Check if the student's answer is the same type as the Teacher's. */
+ SameType:ATSameTypefun(expr, TAns),
+ if ev(is(SameType[2]=false),simp) then print(SameType[4])
+ else (_RESET_NOTES(),_RESET_FEEDBACK()),
+ /* Check variables in the answer. */
+ chkvars:stack_validate_checkvars(expr, TAns, chkopt),
+ if ev(not(is(chkvars="")), simp) then print(chkvars),
+ /* Check for malformed real sets. */
+ if realset_surface_p(expr) then block([ret],
+ ret:interval_validate_realset(expr),
+ if not(is(ret="")) then print(ret)
+ ),
+ /* Check to see if a variable is also a function name. */
+ fvs1: setify(listofvars(expr)),
+ fvs2: get_ops(expr),
+ fvs: ev(intersection(fvs1, fvs2), simp),
+ if ev(not(is(fvs={})), simp) then
+ print(StackAddFeedback("", "Variable_function", stack_disp(fvs, "i"))),
+ /* Checks fractions are in lowest terms. */
+ if LowestTerms and all_lowest_termsex(expr)=false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* Check for x=1 or 2. */
+ exs:stack_validate_missing_assignment(expr),
+ if first(exs) then
+ print(StackAddFeedback("", "Bad_assignment", stack_disp(second(exs), "i"))),
+ /* Now display the result. */
+ simp: false,
+ expr: detexcolor(expr),
+ return(expr)
+)$
+
+/* Validate an expression without type checking. Floats and mathematical errors only. */
+stack_validate_typeless(expr, LowestTerms, TAns, fltfmt, chkopt, Equiv) := 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 variables in the answer. */
+ chkvars:stack_validate_checkvars(expr, TAns, chkopt),
+ if ev(not(is(chkvars="")), simp) then print(chkvars),
+ /* Check for malformed real sets. */
+ if realset_surface_p(expr) then block([ret],
+ ret:interval_validate_realset(expr),
+ if not(is(ret="")) then print(ret)
+ ),
+ /* Check to see if a variable is also a function name. */
+ fvs1: setify(listofvars(expr)),
+ fvs2: get_ops(expr),
+ fvs: ev(intersection(fvs1, fvs2), simp),
+ if ev(not(is(fvs={})), simp) then
+ print(StackAddFeedback("", "Variable_function", stack_disp(fvs, "i"))),
+ /* Check for floats, and if there are any then throw an error */
+ /* Checks fractions are in lowest terms */
+ if LowestTerms and all_lowest_termsex(expr) = false then
+ print(StackAddFeedback("", "Lowest_Terms")),
+ /* Check for x=1 or 2. */
+ exs: stack_validate_missing_assignment(expr),
+ if first(exs) then
+ print(StackAddFeedback("", "Bad_assignment", stack_disp(second(exs), "i"))),
+ /* Additional tests which restrict the equivalence input type. */
+ if Equiv and op_usedp(expr, set) then print(StackAddFeedback("", "Equiv_Illegal_set")),
+ if Equiv and op_usedp(expr, "{") then print(StackAddFeedback("", "Equiv_Illegal_set")),
+ if Equiv and op_usedp(expr, "[") then print(StackAddFeedback("", "Equiv_Illegal_list")),
+ if Equiv and op_usedp(expr, matrix) then print(StackAddFeedback("", "Equiv_Illegal_matrix")),
+ /* Now display the result. */
+ simp: false,
+ return(expr)
+)$
+
+/* This function replaces all variables starting with a % sign with elements from var */
+stack_strip_percent(ex,var) := block([lv1, lv2, subcount, indx,exs],
+ subcount:0,
+ lv2:[],
+ lv1:listofvars(ex),
+ if [] = lv then return(ex),
+ for indx:1 thru length(lv1) do (
+ if cequal(charat(string(lv1[indx]), 1),"%") then block(
+ subcount:subcount+1,
+ lv2:append(lv2, [lv1[indx] = var[subcount]])
+ )
+ ),
+ if not(emptyp(lv2)) then exs:subst(lv2, ex) else exs:ex,
+ return(exs)
+)$
+
+/* Create a list of numbered variables. */
+stack_var_makelist(ex, n1) := block(
+ if not(atom(ex)) then error("stack_var_makelist: first argument must be an atom"),
+ if not(integerp(n1)) or not(ev(is(n1>=0), simp)) then error("stack_var_makelist: second argument must be a non-negative integer"),
+ return(ev(makelist(vconcat(ex,k), k, 0, n1), simp))
+)$
+
+/* Spot the very specific pattern x=1 nounor 2 instead of x=1 nounor x=2. */
+/* Returns a list: [pattern found, changed expression]. */
+stack_validate_missing_assignment(ex) := block([ret, ex2, v, exop],
+ if not(safe_op(ex)="nounor" or safe_op(ex)="nounand")
+ then return([false, ex]),
+ if length(listofvars(ex))#1
+ then return([false, ex]),
+ ex2: args(ex),
+ exop: op(ex),
+ /* Do we have any equations which look like assignments? */
+ if not(any_listp(lambda([ex], equationp(ex) and atom(lhs(ex)) and not(simp_numberp(lhs(ex)))),ex2))
+ then return([false, ex]),
+ /* Do any of them look bad, that just a number on its own? */
+ if all_listp(lambda([ex], not(is(listofvars(ex)=[]))), ex2)
+ then return([false, ex]),
+ v: first(listofvars(ex)),
+ ex: maplist(lambda([ex], if (equationp(ex) and atom(lhs(ex)) and not(simp_numberp(lhs(ex)))) then ex else v=ex), ex2),
+ ex: apply(exop, ex),
+ return([true, ex])
+)$
+
+/* ****************************************** */
+/* Functions associated with validators */
+/* ****************************************** */
+
+/**
+ * A convenience function for combining validators, to be used with the input validator system.
+ * Executes all functions received and produces a combined output.
+ *
+ * @param[expression] the input value to be validated.
+ * @param[list of identifers] the names of the functions to be combined.
+ * @return[string or CASText] the result of those validations.
+ */
+stack_multi_validator(ex, validators):=block([%_tmp, %_val, %_errfound],
+ %_tmp:[],
+ %_errfound:false,
+ for %_val in validators do block([%_tested],
+ /* Since we evluate all functions we have no opportunity for guard clauses.
+ Hence, we expect some errors, and therefore don't use EC.
+ Instead errors are trapped at this level, not the session level.
+ */
+ %_tested:errcatch(%_val(ex)),
+ if emptyp(%_tested) then
+ %_errfound:true
+ else
+ %_tmp:append(%_tmp,%_tested)
+ ),
+ /* Add the error message only once. */
+ /* See https://github.com/maths/moodle-qtype_stack/issues/870 on how to generate this from a castext() call. */
+ if %_errfound then %_tmp:append(%_tmp, [ ["%root",["%cs","inputvalidatorerrcouldnot"]] ]),
+ /* Remove all valid results.*/
+ %_tmp: delete("", delete(true, %_tmp)),
+ if %_tmp = [] then return(""),
+ /* Then concatenate CASText2 segments. Add spaces between multiple failures. */
+ /* `rest` currently requires that simp, for negative arguments. */
+ %_tmp:ev(lreduce(castext_concat, rest(join(%_tmp, makelist(" ", length(%_tmp))), -1)), simp)
+);
+
+/**
+ * A convenience function for combining validators, to be used with the input validator system.
+ * Executes functions received until one fails, and returns the first output as fail.
+ * Any errors thrown should be considered authoring errors.
+ *
+ * @param[expression] the input value to be validated.
+ * @param[list of identifers] the names of the functions to be combined.
+ * @return[string or CASText] the result of those validations.
+ */
+stack_seq_validator(ex, validators):=block([%_tmp, %_val, %_continue],
+ %_tmp:"",
+ %_continue:true,
+ /* Use a loop instead of while to simplify test fail logic. */
+ for %_val in validators do block(
+ if %_continue then block(
+ /* Don't use _EC or errcatch as only one test should fail. Any error is a genuine authoring error. */
+ %_tmp:%_val(ex),
+ if is(%_tmp=true) or is(%_tmp="") then (
+ %_continue:true
+ ) else (
+ %_continue:false
+ )
+ )
+ ),
+ %_tmp
+);
+
+/* ****************************************** */
+/* Supported validators */
+/* ****************************************** */
diff --git a/stack/2023102700/maximalocal.mac.template b/stack/2023102700/maximalocal.mac.template
new file mode 100644
index 0000000000000000000000000000000000000000..3805d915df0146961464e35c463bd422cf78f4f2
--- /dev/null
+++ b/stack/2023102700/maximalocal.mac.template
@@ -0,0 +1,41 @@
+/* ***********************************************************************/
+/* This file is automatically generated at installation time. */
+/* The purpose is to transfer configuration settings to Maxima. */
+/* Hence, you should not edit this file. Edit your configuration. */
+/* This file is regularly overwritten, so your changes will be lost. */
+/* ***********************************************************************/
+
+/* File generated on October 31, 2023, 6:23 pm */
+
+/* Add the location to Maxima's search path */
+file_search_maxima:append( [sconcat("${LIB}/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat("${LIB}/###.{lisp}")] , file_search_lisp)$
+file_search_maxima:append( [sconcat("${LOG}/###.{mac,mc}")] , file_search_maxima)$
+file_search_lisp:append( [sconcat("${LOG}/###.{lisp}")] , file_search_lisp)$
+
+STACK_SETUP(ex):=block(
+ MAXIMA_VERSION_NUM_EXPECTED:44,
+ MAXIMA_PLATFORM:"server",
+ maxima_tempdir:"${TMP}",
+ IMAGE_DIR:"${PLOT}",
+ PLOT_SIZE:[450,300],
+ PLOT_TERMINAL:"svg",
+ PLOT_TERM_OPT:"dynamic font \",11\" linewidth 1.2",
+ DEL_CMD:"rm",
+ GNUPLOT_CMD:"gnuplot",
+ MAXIMA_VERSION_EXPECTED:"5.44.0",
+ URL_BASE:"!ploturl!",
+ /* Define units available in STACK. */
+ stack_unit_si_prefix_code:[y, z, a, f, p, n, u, m, c, d, da, h, k, M, G, T, P, E, Z, Y],
+ stack_unit_si_prefix_multiplier:[10^-24, 10^-21, 10^-18, 10^-15, 10^-12, 10^-9, 10^-6, 10^-3, 10^-2, 10^-1, 10, 10^2, 10^3, 10^6, 10^9, 10^12, 10^15, 10^18, 10^21, 10^24],
+ stack_unit_si_prefix_tex:["\\mathrm{y}", "\\mathrm{z}", "\\mathrm{a}", "\\mathrm{f}", "\\mathrm{p}", "\\mathrm{n}", "\\mu ", "\\mathrm{m}", "\\mathrm{c}", "\\mathrm{d}", "\\mathrm{da}", "\\mathrm{h}", "\\mathrm{k}", "\\mathrm{M}", "\\mathrm{G}", "\\mathrm{T}", "\\mathrm{P}", "\\mathrm{E}", "\\mathrm{Z}", "\\mathrm{Y}"],
+ stack_unit_si_unit_code:[m, l, L, g, t, s, h, Hz, Bq, cd, N, Pa, cal, Cal, Btu, eV, J, W, Wh, A, ohm, C, V, F, S, Wb, T, H, Gy, rem, Sv, lx, lm, mol, M, kat, rad, sr, K, VA, eV, Ci],
+ stack_unit_si_unit_conversions:[m, m^3/1000, m^3/1000, kg/1000, 1000*kg, s, s*3600, 1/s, 1/s, cd, (kg*m)/s^2, kg/(m*s^2), 4.2*J, 4200*J, 1055*J, 1.602177e-19*J, (kg*m^2)/s^2, (kg*m^2)/s^3, 3600*(kg*m^2)/s^2, A, (kg*m^2)/(s^3*A^2), s*A, (kg*m^2)/(s^3*A), (s^4*A^2)/(kg*m^2), (s^3*A^2)/(kg*m^2), (kg*m^2)/(s^2*A), kg/(s^2*A), (kg*m^2)/(s^2*A^2), m^2/s^2, 0.01*Sv, m^2/s^2, cd/m^2, cd, mol, mol/(m^3/1000), mol/s, rad, sr, K, VA, 1.602176634E-19*J, Ci],
+ stack_unit_si_unit_tex:["\\mathrm{m}", "\\mathrm{l}", "\\mathrm{L}", "\\mathrm{g}", "\\mathrm{t}", "\\mathrm{s}", "\\mathrm{h}", "\\mathrm{Hz}", "\\mathrm{Bq}", "\\mathrm{cd}", "\\mathrm{N}", "\\mathrm{Pa}", "\\mathrm{cal}", "\\mathrm{cal}", "\\mathrm{Btu}", "\\mathrm{eV}", "\\mathrm{J}", "\\mathrm{W}", "\\mathrm{Wh}", "\\mathrm{A}", "\\Omega", "\\mathrm{C}", "\\mathrm{V}", "\\mathrm{F}", "\\mathrm{S}", "\\mathrm{Wb}", "\\mathrm{T}", "\\mathrm{H}", "\\mathrm{Gy}", "\\mathrm{rem}", "\\mathrm{Sv}", "\\mathrm{lx}", "\\mathrm{lm}", "\\mathrm{mol}", "\\mathrm{M}", "\\mathrm{kat}", "\\mathrm{rad}", "\\mathrm{sr}", "\\mathrm{K}", "\\mathrm{VA}", "\\mathrm{eV}", "\\mathrm{Ci}"],
+ stack_unit_other_unit_code:[min, amu, u, mmHg, bar, ha, cc, gal, mbar, atm, torr, rev, deg, rpm, au, Da, Np, B, dB, day, year, hp, in, ft, yd, mi, lb],
+ stack_unit_other_unit_conversions:[s*60, amu, amu, 133.322387415*Pa, 10^5*Pa, 10^4*m^2, m^3*10^(-6), 3.785*l, 10^2*Pa, 101325*Pa, 101325/760*Pa, 2*pi*rad, pi*rad/180, pi*rad/(30*s), 149597870700*m, 1.660539040E-27*kg, Np, B, dB, 86400*s, 3.156e7*s, 746*W, in, 12*in, 36*in, 5280*12*in, 4.4482*N],
+ stack_unit_other_unit_tex:["\\mathrm{min}", "\\mathrm{amu}", "\\mathrm{u}", "\\mathrm{mmHg}", "\\mathrm{bar}", "\\mathrm{ha}", "\\mathrm{cc}", "\\mathrm{gal}", "\\mathrm{mbar}", "\\mathrm{atm}", "\\mathrm{torr}", "\\mathrm{rev}", "\\mathrm{{}^{o}}", "\\mathrm{rpm}", "\\mathrm{au}", "\\mathrm{Da}", "\\mathrm{Np}", "\\mathrm{B}", "\\mathrm{dB}", "\\mathrm{day}", "\\mathrm{year}", "\\mathrm{hp}", "\\mathrm{in}", "\\mathrm{ft}", "\\mathrm{yd}", "\\mathrm{mi}", "\\mathrm{lb}"],
+ true)$
+/* Load the main libraries. */
+/* load("stackmaxima.mac")$ */
+print(sconcat("[ STACK-Maxima started, library version ", stackmaximaversion, " ]"))$
diff --git a/versions b/versions
index 3467690e72abe6c9aaff877686c0f02f967c7925..51cf59bc9e673401ebbffc8c09d7a9e17299364c 100644
--- a/versions
+++ b/versions
@@ -1,5 +1,4 @@
# stack, maxima, sbcl
-2017121800 5.41.0 2.1.4
2018030500 5.41.0 2.1.4
2018080600 5.41.0 2.1.4
2019090200 5.41.0 2.1.4
@@ -19,3 +18,4 @@
2023052400 5.44.0 2.2.6
2023060500 5.44.0 2.2.6
2023072101 5.44.0 2.2.6
+2023102700 5.44.0 2.2.6