diff --git a/changelog b/changelog index a3e00c4..d800fbe 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090820 tpd src/axiom-website/patches.html 20090820.01.tpd.patch +20090820 tpd src/interp/Makefile move i-coerfn.boot to i-coerfn.lisp +20090820 tpd src/interp/i-coerfn.lisp added, rewritten from i-coerfn.boot +20090820 tpd src/interp/i-coerfn.boot removed, rewritten to i-coerfn.lisp 20090819 tpd src/axiom-website/patches.html 20090819.02.tpd.patch 20090819 tpd src/interp/Makefile move i-coerce.boot to i-coerce.lisp 20090819 tpd src/interp/i-coerce.lisp added, rewritten from i-coerce.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ea758bc..2636e0a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1822,5 +1822,7 @@ i-code.lisp rewrite from boot to lisp
books/bookvol5 add Steven Segletes to credits
20090819.02.tpd.patch i-coerce.lisp rewrite from boot to lisp
+20090820.01.tpd.patch +i-coerfn.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 78afe67..fd98daf 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -427,7 +427,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ - ${DOC}/i-coerfn.boot.dvi \ ${DOC}/i-eval.boot.dvi ${DOC}/i-funsel.boot.dvi \ ${DOC}/i-intern.boot.dvi \ ${DOC}/i-map.boot.dvi ${DOC}/incl.boot.dvi \ @@ -3098,47 +3097,27 @@ ${MID}/i-coerce.lisp: ${IN}/i-coerce.lisp.pamphlet @ -\subsection{i-coerfn.boot} +\subsection{i-coerfn.lisp} <>= -${OUT}/i-coerfn.${O}: ${MID}/i-coerfn.clisp - @ echo 288 making ${OUT}/i-coerfn.${O} from ${MID}/i-coerfn.clisp - @ (cd ${MID} ; \ +${OUT}/i-coerfn.${O}: ${MID}/i-coerfn.lisp + @ echo 136 making ${OUT}/i-coerfn.${O} from ${MID}/i-coerfn.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-coerfn.clisp"' \ + echo '(progn (compile-file "${MID}/i-coerfn.lisp"' \ ':output-file "${OUT}/i-coerfn.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-coerfn.clisp"' \ + echo '(progn (compile-file "${MID}/i-coerfn.lisp"' \ ':output-file "${OUT}/i-coerfn.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-coerfn.clisp: ${IN}/i-coerfn.boot.pamphlet - @ echo 289 making ${MID}/i-coerfn.clisp \ - from ${IN}/i-coerfn.boot.pamphlet +<>= +${MID}/i-coerfn.lisp: ${IN}/i-coerfn.lisp.pamphlet + @ echo 137 making ${MID}/i-coerfn.lisp from \ + ${IN}/i-coerfn.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-coerfn.boot.pamphlet >i-coerfn.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-coerfn.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-coerfn.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-coerfn.boot ) - -@ -<>= -${DOC}/i-coerfn.boot.dvi: ${IN}/i-coerfn.boot.pamphlet - @echo 290 making ${DOC}/i-coerfn.boot.dvi \ - from ${IN}/i-coerfn.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-coerfn.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-coerfn.boot ; \ - rm -f ${DOC}/i-coerfn.boot.pamphlet ; \ - rm -f ${DOC}/i-coerfn.boot.tex ; \ - rm -f ${DOC}/i-coerfn.boot ) + ${TANGLE} ${IN}/i-coerfn.lisp.pamphlet >i-coerfn.lisp ) @ @@ -6582,8 +6561,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet deleted file mode 100644 index e07062c..0000000 --- a/src/interp/i-coerfn.boot.pamphlet +++ /dev/null @@ -1,2306 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-coerfn.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Special coercion routines - -This is the newly revised set of coercion functions to work with -the new library and the new runtime system. - -coerceByTable is driven off $CoerceTable which is used to match -the top-level constructors of the source and object types. The -form of $CoerceTable is an alist where the "properties" are the -source top-level constructors and the values are triples - target-domain coercion-type function -where target-domain is the top-level constructor of the target, -coercion-type is one of 'total, 'partial or 'indeterm, and -function is the name of the function to call to handle the -coercion. coercion-type is used by canCoerce and friends: 'total -means that a coercion can definitely be performed, 'partial means -that one cannot tell whether a coercion can be performed unless -you have the actual data (like telling whether a Polynomial Integer -can be coerced to an Integer: you have to know whether it is a -constant polynomial), and 'indeterm means that you might be able -to tell without data, but you need to call the function with the -argument "$fromCoerceable$" for a response of true or false. As an -example of this last kind, you may be able to coerce a list to a -vector but you have to know what the underlying types are. So -List Integer is coerceable to Vector Integer but List Float is -not necessarily coerceable to Vector Integer. - -The functions always take three arguments: - value this is the unwrapped source object - source-type this is the type of the source - target-type this is the requested type of the target -For ethical reasons and to avoid eternal damnation, we try to use -library functions to perform a lot of the structure manipulations. -However, we sometimes cheat for efficiency reasons, particularly to -avoid intermediate instantiations. - -the following are older comments: - -This file contains the special coercion routines that convert from -one datatype to another in the interpreter. The choice of the -primary special routine is made by the function coerceByTable. Note -that not all coercions use these functions, as some are done via SPAD -algebra code and controlled by the function coerceByFunction. See -the file COERCE BOOT for more information. - -some assumption about the call of commute and embed functions: -embed functions are called for one level embedding only, - e.g. I to P I, but not I to P G I -commute functions are called for two types which differ only in the - permutation of the two top type constructors - e.g. G P RN to P G RN, but not G P I to P G RN or - P[x] G RN to G P RN - -all functions in this file should call canCoerce and coerceInt, as - opposed to canCoerceFrom and coerceInteractive - -all these coercion functions have the following result: -1. if u=$fromCoerceable$, then TRUE or NIL -2. if the coercion succeeds, the coerced value (this may be NIL) -3. if the coercion fails, they throw to a catch point in - coerceByTable - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -SETANDFILEQ($coerceFailure,GENSYM()) - -position1(x,y) == - -- this is used where we want to assume a 1-based index - 1 + position(x,y) - ---% Direct Product, New and Old - -DP2DP(u,source is [.,n,S],target is [.,m,T]) == - n ^= m => nil - u = '_$fromCoerceable_$ => canCoerce(S,T) - null (u' := coerceInt(objNewWrap(u,['Vector,S]),['Vector,T])) => - coercionFailure() - objValUnwrap u' - ---% Distributed Multivariate Polynomials, New and Old - -Dmp2Dmp(u,source is [dmp,v1,S], target is [.,v2,T]) == - -- the variable lists must share some variables, or u is a constant - u = '_$fromCoerceable_$ => - v:= INTERSECTION(v1,v2) - v and - w2:= SETDIFFERENCE(v2,v) - t1:= if w1 then [dmp,w1,S] else S - t2:= if w2 then [dmp,w2,T] else T - canCoerce(t1,t2) - null u => domainZero(target) - u is [[e,:c]] and e=LIST2VEC [0 for v in v1] => - z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) - coercionFailure() - v:= INTERSECTION(v1,v2) => - w1:= SETDIFFERENCE(v1,v) => - coerceDmp1(u,source,target,v,w1) - coerceDmp2(u,source,target) - coercionFailure() - -coerceDmp1(u,source is [.,v1,S],target is [.,v2,T],v,w) == - -- coerces one Dmp to another, where v1 is not a subset of v2 - -- v is the intersection, w the complement of v1 and v2 - t:= ['DistributedMultivariatePolynomial,w,S] - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - pat1:= [MEMBER(x,v) for x in v1] - pat2:= [MEMBER(x,w) for x in v1] - pat3:= [MEMBER(x,v) and POSN1(x,v) for x in v2] - for [e,:c] in u until not z repeat - exp:= LIST2VEC [y for x in pat2 for y in VEC2LIST e | x] - z:= coerceInt(objNewWrap([CONS(exp,c)],t),target) => - li:= [y for x in pat1 for y in VEC2LIST e | x] - a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat3],one)] - x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) - z => x - coercionFailure() - -coerceDmp2(u,source is [.,v1,S],target is [.,v2,T]) == - -- coerces one Dmp to another, where v1 is included in v2 - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - pat:= [MEMBER(x,v1) and POSN1(x,v1) for x in v2] - for [e,:c] in u until not z repeat - z:= coerceInt(objNewWrap(c,S),target) => - li:= VEC2LIST e - a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat],one)] - x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) - NIL - z => x - coercionFailure() - -Dmp2Expr(u,source is [dmp,vars,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - null vars => - [[., :c]] := u - not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() - objValUnwrap(c) - - syms := [objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) for - var in vars] - sum := domainZero(target) - - plus := getFunctionFromDomain("+", target, [target, target]) - mult := getFunctionFromDomain("*", target, [target, target]) - expn := getFunctionFromDomain("**", target, [target, $Integer]) - - for [e, :c] in u repeat - not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() - c := objValUnwrap(c) - term := domainOne(target) - for i in 0.. for sym in syms repeat - exp := e.i - e.i > 0 => term := SPADCALL(term, SPADCALL(sym, e.i, expn), mult) - sum := SPADCALL(sum, SPADCALL(c, term, mult), plus) - - sum - -Dmp2Mp(u, source is [dmp, x, S], target is [mp, y, T]) == - source' := [dmp,y,T] - u = '_$fromCoerceable_$ => - x = y => canCoerce(S,T) - canCoerce(source',target) - null u => domainZero(target) -- 0 dmp is = nil - x ^= y => - (u' := coerceInt(objNewWrap(u,source),source')) or coercionFailure() - (u' := coerceInt(u',target)) or coercionFailure() - objValUnwrap(u') - - -- slight optimization for case #u = 1, x=y , #x =1 and S=T - -- I know it's pathological, but it may avoid an instantiation - (x=y) and (1 = #u) and (1 = #x) and (S = T) => - [1,1,[(CAAR u).0,0,:CDAR u]] - - (u' := coerceDmpCoeffs(u,S,T)) = 'failed => - coercionFailure() - plusfunc := getFunctionFromDomain("+",target,[target,target]) - u'' := genMpFromDmpTerm(u'.0, 0) - for i in 1..(#u' - 1) repeat - u'' := SPADCALL(u'',genMpFromDmpTerm(u'.i, 0),plusfunc) - u'' - -coerceDmpCoeffs(u,S,T) == - -- u is a dmp, S is domain of coeffs, T is domain to coerce coeffs to - S = T => u - u' := nil - bad := nil - for [e,:c] in u repeat - bad => nil - null (c' := coerceInt(objNewWrap(c,S),T)) => return (bad := true) - u' := [[e,:objValUnwrap(c')],:u'] - bad => 'failed - nreverse u' - -sortAndReorderDmpExponents(u,vl) == - vl' := reverse MSORT vl - n := (-1) + #vl - pos := LIST2VEC LZeros (n+1) - for i in 0..n repeat pos.i := position(vl.i,vl') - u' := nil - for [e,:c] in u repeat - e' := LIST2VEC LZeros (n+1) - for i in 0..n repeat e'.(pos.i) := e.i - u' := [[e',:c],:u'] - reverse u' - -domain2NDmp(u, source, target is [., y, T]) == - target' := ['DistributedMultivariatePolynomial,y,T] - u = '_$fromCoerceable_$ => canCoerce(source,target') - (u' := coerceInt(objNewWrap(u,source),target')) => - (u'' := coerceInt(u',target)) => - objValUnwrap(u'') - coercionFailure() - coercionFailure() - -Dmp2NDmp(u,source is [dmp,x,S],target is [ndmp,y,T]) == - -- a null DMP = 0 - null u => domainZero(target) - target' := [dmp,y,T] - u = '_$fromCoerceable_$ => Dmp2Dmp(u,source,target') - (u' := Dmp2Dmp(u,source,target')) => addDmpLikeTermsAsTarget(u',target) - coercionFailure() - -addDmpLikeTermsAsTarget(u,target) == - u' := domainZero(target) - func := getFunctionFromDomain("+",target,[target,target]) - for t in u repeat u' := SPADCALL(u',[t],func) - u' - --- rewrite ? -Dmp2P(u, source is [dmp,vl, S], target is [.,T]) == - -- a null DMP = 0 - null u => domainZero(target) - u = '_$fromCoerceable_$ => - t := canCoerce(S,T) - null t => canCoerce(S,target) - t - - S is ['Polynomial,.] => - mp := coerceInt(objNewWrap(u,source),['MultivariatePolynomial,vl,S]) - or coercionFailure() - p := coerceInt(mp,target) or coercionFailure() - objValUnwrap p - - -- slight optimization for case #u = 1, #vl =1 and S=T - -- I know it's pathological, but it may avoid an instantiation - (1 = #u) and (1 = #vl) and (S = T) => - (lexp:= (CAAR u).0) = 0 => [1,:CDAR u] - [1,vl.0,[lexp,0,:CDAR u]] - - vl' := reverse MSORT vl - source' := [dmp,vl',S] - target' := ['MultivariatePolynomial,vl',S] - u' := sortAndReorderDmpExponents(u,vl) - u' := coerceInt(objNewWrap(u',source'),target') - if u' then - u' := translateMpVars2PVars (objValUnwrap(u'),vl') - u' := coerceInt(objNewWrap(u',['Polynomial,S]),target) - u' => objValUnwrap(u') - -- get drastic. create monomials - source' := [dmp,vl,T] - u' := domainZero(target) - oneT := domainOne(T) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - for [e,:c] in u repeat - (c' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - (e' := coerceInt(objNewWrap([[e,:oneT]],source'),target)) or - coercionFailure() - t := SPADCALL(objValUnwrap(e'),objValUnwrap(c'),multfunc) - u' := SPADCALL(u',t,plusfunc) - coercionFailure() - -translateMpVars2PVars (u, vl) == - u is [ =1, v, :termlist] => - [ 1, vl.(v-1), - :[[e,:translateMpVars2PVars(c,vl)] for [e,:c] in termlist]] - u - -Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) == - null u => -- this is true if u = 0 - domainZero(target) - - u = '_$fromCoerceable_$ => - MEMBER(var,vl) => - vl' := REMOVE(vl,var) - null vl' => -- no remaining variables - canCoerce(S,T) - null rest vl' => -- one remaining variable - canCoerce([up,first vl',S],T) - canCoerce([dmp,vl',S], T) - canCoerce(source,T) - - -- check constant case - (null rest u) and (first(u) is [e,:c]) and - ( and/[(0 = e.i) for i in 0..(-1 + #vl)] ) => - (x := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(x) - - -- check non-member case - null MEMBER(var,vl) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap u']] - - vl' := REMOVE(vl,var) - - -- only one variable in DMP case - null vl' => - u' := nreverse SORTBY('CAR,[[e.0,:c] for [e,:c] in u]) - (u' := coerceInt(objNewWrap(u',[up,var,S]),target)) or - coercionFailure() - objValUnwrap u' - - S1 := [dmp,vl',S] - plusfunc:= getFunctionFromDomain('_+,T,[T,T]) - zero := getConstantFromDomain('(Zero),T) - x := NIL - pos:= POSN1(var,vl) - for [e,:c] in u until not y repeat - exp:= e.pos - e1:= removeVectorElt(e,pos) - y:= coerceInt(objNewWrap([[e1,:c]],S1),T) => - -- need to be careful about zeros - p:= ASSQ(exp,x) => - c' := SPADCALL(CDR p,objValUnwrap(y),plusfunc) - c' = zero => x := REMALIST(x,exp) - RPLACD(p,c') - zero = objValUnwrap(y) => 'iterate - x := CONS(CONS(exp,objValUnwrap(y)),x) - y => nreverse SORTBY('CAR,x) - coercionFailure() - -removeVectorElt(v,pos) == - -- removes the pos'th element from vector v - LIST2VEC [x for x in VEC2LIST v for y in 0.. | not (y=pos)] - -removeListElt(l,pos) == - pos = 0 => CDR l - [CAR l, :removeListElt(CDR l,pos-1)] - -NDmp2domain(u,source is [ndmp,x,S],target) == - -- a null NDMP = 0 - null u => domainZero(target) - dmp := 'DistributedMultivariatePolynomial - source' := [dmp,x,S] - u = '_$fromCoerceable_$ => canCoerce(source',target) - u' := addDmpLikeTermsAsTarget(u,source') - (u'' := coerceInt(objNewWrap(u',source'),target)) => - objValUnwrap(u'') - coercionFailure() - -NDmp2NDmp(u,source is [ndmp,x,S],target is [.,y,T]) == - -- a null NDMP = 0 - null u => domainZero(target) - dmp := 'DistributedMultivariatePolynomial - source' := [dmp,x,S] - target' := [dmp,y,T] - u = '_$fromCoerceable_$ => canCoerce(source',target') - u' := addDmpLikeTermsAsTarget(u,source') - (u'' := coerceInt(objNewWrap(u',source'),target')) => - addDmpLikeTermsAsTarget(objValUnwrap(u''),target) - coercionFailure() - ---% Expression - -Expr2Complex(u,source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => nil -- can't tell, in general - - not member(S, [$Integer, $Float, $DoubleFloat]) => coercionFailure() - not member(T, [$Float, $DoubleFloat]) => coercionFailure() - - complexNumeric := getFunctionFromDomain("complexNumeric", ['Numeric, S], [source]) - - -- the following might fail - cf := SPADCALL(u,complexNumeric) -- returns a Float - T = $DoubleFloat => - null (z := coerceInt(objNewWrap(cf, ['Complex, $Float]), ['Complex, $DoubleFloat])) => - coercionFailure() - objValUnwrap z - cf - -Expr2Dmp(u,source is [Expr,S], target is [dmp,v2,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - - null v2 => - not (z := coerceInt(objNewWrap(u, source), T)) => coercionFailure() - [[LIST2VEC NIL, :objValUnwrap z]] - - obj := objNewWrap(u, source) - univ := coerceInt(obj, ['UnivariatePolynomial, first v2, T]) - not univ => - T = source => coercionFailure() - not (z := coerceInt(obj, [dmp, v2, source])) => - coercionFailure() - z := objValUnwrap z - for term in z repeat - [., :c] := term - not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() - RPLACD(term, objValUnwrap c) - z - - univ := objValUnwrap univ - - -- only one variable - - null rest v2 => - for term in univ repeat - RPLACA(term, VECTOR CAR term) - univ - - -- more than one variable - - summands := nil - for [e,:c] in univ repeat - summands := Expr2Dmp1(summands, - LIST2VEC [e, :[0 for v in rest v2]], c, T, 1, rest v2, T) - - plus := getFunctionFromDomain("+", target, [target, target]) - sum := domainZero target - for summand in summands repeat - sum := SPADCALL([summand], sum, plus) - sum - -Expr2Dmp1(summands, vec, c, source, index, varList, T) == - if null varList then - if not (source = T) then - not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() - c := objValUnwrap c - summands := [[vec, :c], :summands] - else - univ := coerceInt(objNewWrap(c, source), - ['UnivariatePolynomial, first varList, T]) - univ := objValUnwrap univ - - for [e,:c] in univ repeat - vec := COPY_-SEQ vec - vec.index := e - summands := Expr2Dmp1(summands, vec, c, T, index+1, rest varList, T) - summands - -Expr2Mp(u,source is [Expr,S], target is [.,v2,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - - dmp := ['DistributedMultivariatePolynomial,v2,T] - d := Expr2Dmp(u,source, dmp) - not (m := coerceInt(objNewWrap(d, dmp), target)) => coercionFailure() - objValUnwrap m - -Expr2Up(u,source is [Expr,S], target is [.,var,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - kernelFunc := getFunctionFromDomain("kernels", source, [source]) - kernelDom := ['Kernel, source] - nameFunc := getFunctionFromDomain("name", kernelDom, [kernelDom]) - kernels := SPADCALL(u,kernelFunc) - v1 := [SPADCALL(kernel, nameFunc) for kernel in kernels] - - not member(var, v1) => coercionFailure() - - -- variable is a kernel - - varKernel := kernels.(POSN1(var, v1)) - univFunc := getFunctionFromDomain("univariate", source, [source, kernelDom]) - sup := ['SparseUnivariatePolynomial, source] - - fracUniv := SPADCALL(u, varKernel, univFunc) - denom := CDR fracUniv - - not equalOne(denom, sup) => coercionFailure() - - numer := CAR fracUniv - uniType := ['UnivariatePolynomial, var, source] - (z := coerceInt(objNewWrap(numer, uniType), target)) => objValUnwrap z - coercionFailure() - ---% Kernels over Expr - -Ker2Ker(u,source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, T) - not (m := coerceInt(objNewWrap(u, source), S)) => coercionFailure() - u' := objValUnwrap m - not (m' := coerceInt(objNewWrap(u', S), T)) => coercionFailure() - u'' := objValUnwrap m' - not (m'' := coerceInt(objNewWrap(u'', T), target)) => coercionFailure() - objValUnwrap m'' - -Ker2Expr(u,source is [.,S], target) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - not (m := coerceByFunction(objNewWrap(u, source), S)) => coercionFailure() - u':= objValUnwrap m - not (m' := coerceInt(objNewWrap(u', S), target)) => coercionFailure() - objValUnwrap m' - - ---% Factored objects - -Factored2Factored(u,oldmode,newmode) == - [.,oldargmode,:.]:= oldmode - [.,newargmode,:.]:= newmode - u = '_$fromCoerceable_$ => canCoerce(oldargmode,newargmode) - u' := unwrap u - unit' := coerceInt(objNewWrap(first u',oldargmode),newargmode) - null unit' => coercionFailure() - factors := KDR u' - factors' := [(coerceFFE(x,oldargmode,newargmode)) for x in factors] - MEMBER('failed,factors') => coercionFailure() - [objValUnwrap(unit'),:factors'] - -coerceFFE(ffe, oldmode, newmode) == - fac' := coerceInt(objNewWrap(ffe.1,oldmode),newmode) - null fac' => 'failed - LIST2VEC [ffe.0,objValUnwrap(fac'),ffe.2] - ---% Complex - -Complex2underDomain(u,[.,S],target) == - u = '_$fromCoerceable_$ => nil - [r,:i] := u - i=domainZero(S) => - [r',.,.]:= coerceInt(objNewWrap(r,S),target) or - coercionFailure() - r' - coercionFailure() - -Complex2FR(u,S is [.,R],target is [.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R = $Integer => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => ['GaussianFactorizationPackage] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Complex2Expr(u, source is [.,S], target is [., T]) == - u = '_$fromCoerceable_$ => - T is ['Complex, T1] and canCoerceFrom(S, T1) or coercionFailure() - E := defaultTargetFE source - negOne := coerceInt(objNewWrap(-1, $Integer), E) - null negOne => coercionFailure() - sqrtFun := getFunctionFromDomain('sqrt, E, [E]) - i := SPADCALL(objValUnwrap negOne, sqrtFun) - realFun := getFunctionFromDomain('real, source, [source]) - imagFun := getFunctionFromDomain('imag, source, [source]) - real := SPADCALL(u, realFun) - imag := SPADCALL(u, imagFun) - realExp := coerceInt(objNewWrap(real, S), E) - null realExp => coercionFailure() - imagExp := coerceInt(objNewWrap(imag, S), E) - null imagExp => coercionFailure() - timesFun := getFunctionFromDomain('_*, E, [E, E]) - plusFun := getFunctionFromDomain('_+, E, [E, E]) - newVal := SPADCALL(objValUnwrap(realExp), - SPADCALL(i, objValUnwrap imagExp, timesFun), plusFun) - newObj := objNewWrap(newVal, E) - finalObj := coerceInt(newObj, target) - finalObj => objValUnwrap finalObj - coercionFailure() - ---% Integer - -I2EI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if not ODDP(n) then n else coercionFailure() - -I2OI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if ODDP(n) then n else coercionFailure() - -I2PI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if n > 0 then n else coercionFailure() - -I2NNI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if n >= 0 then n else coercionFailure() - ---% List - -L2Tuple(val, source is [.,S], target is [.,T]) == - val = '_$fromCoerceable_$ => canCoerce(S,T) - null (object := coerceInt1(mkObjWrap(val,source), ['List, T])) => - coercionFailure() - asTupleNew0 objValUnwrap object - -L2DP(l, source is [.,S], target is [.,n,T]) == - -- need to know size of the list - l = '_$fromCoerceable_$ => nil - n ^= SIZE l => coercionFailure() - (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),['Vector,T])) or - coercionFailure() - V2DP(objValUnwrap v, ['Vector, T], target) - -V2DP(v, source is [.,S], target is [.,n,T]) == - -- need to know size of the vector - v = '_$fromCoerceable_$ => nil - n ^= SIZE v => coercionFailure() - (v1 := coerceInt(objNewWrap(v,source),['Vector,T])) or - coercionFailure() - dpFun := getFunctionFromDomain('directProduct, target, [['Vector,T]]) - SPADCALL(objValUnwrap v1, dpFun) - -L2V(l, source is [.,S], target is [.,T]) == - l = '_$fromCoerceable_$ => canCoerce(S,T) - (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),target)) or - coercionFailure() - objValUnwrap(v) - -V2L(v, source is [.,S], target is [.,T]) == - v = '_$fromCoerceable_$ => canCoerce(S,T) - (l := coerceInt(objNewWrap(VEC2LIST v,['List,S]),target)) or - coercionFailure() - objValUnwrap(l) - -L2M(u,[.,D],[.,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,#u,# first u) => - u' := nil - for x in u repeat - x' := nil - for y in x repeat - (y' := coerceInt(objNewWrap(y,E),R)) or coercionFailure() - x' := [objValUnwrap(y'),:x'] - u' := [LIST2VEC reverse x',:u'] - LIST2VEC reverse u' - coercionFailure() - -L2Record(l,[.,D],[.,:al]) == - l = '_$fromCoerceable_$ => nil - #l = #al => - v:= [u for x in l for [":",.,D'] in al] where u == - T:= coerceInt(objNewWrap(x,D),D') or return 'failed - objValUnwrap(T) - v = 'failed => coercionFailure() - #v = 2 => [v.0,:v.1] - LIST2VEC v - coercionFailure() - -L2Rm(u,source is [.,D],target is [.,n,m,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,n,m) => - L2M(u,source,['Matrix,R]) - coercionFailure() - -L2Sm(u,source is [.,D],[.,n,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,n,n) => - L2M(u,source,['Matrix,R]) - coercionFailure() - -L2Set(x,source is [.,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - -- call library function brace to get a set - target' := ['Set,S] - u := objNewWrap( - SPADCALL(x,getFunctionFromDomain('brace,target',[source])), - target') - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Set2L(x,source is [.,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - -- call library function destruct to get a list - u := objNewWrap( - SPADCALL(x,getFunctionFromDomain('destruct,source,[source])), - ['List,S]) - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Agg2Agg(x,source is [agg1,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - S = T => coercionFailure() -- library function - target' := [agg1,T] - (u := coerceInt(objNewWrap(x,source),target')) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Agg2L2Agg(x,source is [.,S],target) == - -- tries to use list as an intermediate type - mid := ['List,S] - x = '_$fromCoerceable_$ => - canCoerce(source,mid) and canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,source),mid)) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -isRectangularList(x,p,q) == - p=0 or p=#x => - n:= #first x - and/[n=#y for y in rest x] => p=0 or q=n - ---% Matrix - -M2L(x,[.,S],target) == - mid := ['Vector,['Vector,S]] - x = '_$fromCoerceable_$ => canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() - objValUnwrap u - -M2M(x,[.,R],[.,S]) == - x = '_$fromCoerceable_$ => canCoerce(R,S) - n := # x - m := # x.0 - v := nil - for i in 0..(n-1) repeat - u := nil - for j in 0..(m-1) repeat - y := x.i.j - (y' := coerceInt(objNewWrap(y,R),S)) or coercionFailure() - u := [objValUnwrap y',:u] - v := [LIST2VEC reverse u,:v] - LIST2VEC reverse v - -M2Rm(x,source is [.,R],[.,p,q,S]) == - x = '_$fromCoerceable_$ => nil - n:= #x - m:= #x.0 - n=p and m=q => M2M(x,source,[nil,S]) - coercionFailure() - -M2Sm(x,source is [.,R],[.,p,S]) == - x = '_$fromCoerceable_$ => nil - n:= #x - m:= #x.(0) - n=m and m=p => M2M(x,source,[nil,S]) - coercionFailure() - -M2V(x,[.,S],target) == - mid := ['Vector,['Vector,S]] - x = '_$fromCoerceable_$ => canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() - objValUnwrap u - ---% Multivariate Polynomial - -Mp2Dmp(u, source is [., x, S], target is [dmp, y, T]) == - -- Change the representation to a DMP with the same variables and - -- coerce. - target' := [dmp,x,S] - u = '_$fromCoerceable_$ => canCoerce(target',target) - - -- check if we have a constant - u is [ =0,:c] => - null (u' := coerceInt(objNewWrap(c,S),target)) => - coercionFailure() - objValUnwrap(u') - - plus := getFunctionFromDomain('_+,target',[target',target']) - mult := getFunctionFromDomain('_*,target',[target',target']) - one := domainOne(S) - zero := domainZero(S) - (u' := coerceInt(objNewWrap(Mp2SimilarDmp(u,S,#x,plus,mult,one,zero), - target'),target)) or coercionFailure() - objValUnwrap(u') - -Mp2SimilarDmp(u,S,n,plus,mult,one,zero) == - u is [ =0,:c] => - c = zero => NIL -- zero for dmp - [[LIST2VEC LZeros n,:c]] - u is [ =1,x,:terms] => - u' := NIL -- zero for dmp - for [e,:c] in terms repeat - e' := LIST2VEC LZeros n - e'.(x-1) := e - t := [[e',:one]] - t := SPADCALL(t,Mp2SimilarDmp(c,S,n,plus,mult,one,zero),mult) - u' := SPADCALL(u',t,plus) - u' - -Mp2Expr(u,source is [mp,vars,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - dmp := ['DistributedMultivariatePolynomial, vars, S] - not (d := coerceInt(objNewWrap(u, source), dmp)) => coercionFailure() - Dmp2Expr(objValUnwrap d, dmp, target) - -Mp2FR(u,S is [.,vl,R],[.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => - ovl := ['OrderedVariableList, vl] - ['MultivariateFactorize,ovl, ['IndexedExponents, ovl],R,S] - R is ['Fraction, D] => - ovl := ['OrderedVariableList, vl] - package := ['MRationalFactorize,['IndexedExponents, ovl], ovl, D, S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Mp2Mp(u,source is [mp,x,S], target is [.,y,T]) == - -- need not deal with case of x = y (coerceByMapping) - common := INTERSECTION(y,x) - x' := SETDIFFERENCE(x,common) - y' := SETDIFFERENCE(y,common) - - u = '_$fromCoerceable_$ => - x = y => canCoerce(S,T) - null common => canCoerce(source,T) - null x' => canCoerce(S,target) - null y' => canCoerce([mp,x',S],T) - canCoerce([mp,x',S],[mp,y',T]) - - -- first check for constant case - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - plus := getFunctionFromDomain('_+,target,[target,target]) - - -- now no-common-variables case - - null common => - times := getFunctionFromDomain('_*,target,[target,target]) - expn := getFunctionFromDomain('_*_*,target, - [target,$NonNegativeInteger]) - Mp2MpAux0(u,S,target,x,plus,times,expn) - - -- if source vars are all in target - null x' => - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,y],$NonNegativeInteger]) - Mp2MpAux1(u,S,target,x,y,plus,monom) - - -- if target vars are all in source - null y' => -- change source to MP[common] MP[x'] S - univariate := getFunctionFromDomain('univariate, - source,[source,['OrderedVariableList,x]]) - u' := Mp2MpAux2(u,x,common,x',common,x',univariate,S,NIL) - (u' := coerceInt(objNewWrap(u', [mp,common,[mp,x',S]]),target)) or - coercionFailure() - objValUnwrap(u') - - -- we have a mixture - (u' := coerceInt(objNewWrap(u,source),[mp,common,[mp,x',S]])) or - coercionFailure() - (u' := coerceInt(u',target)) or coercionFailure() - objValUnwrap(u') - -Mp2MpAux0(u,S,target,vars,plus,times,expn) == - -- for case when no common variables - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - [.,var,:terms] := u - [mp,.,T] := target - x := coerceInt(objNewWrap(vars.(var-1),['Variable,vars.(var-1)]), - [mp,vars,$Integer]) or coercionFailure() - (x := coerceInt(x,T)) or coercionFailure() - x := [0,:objValUnwrap x] - sum := domainZero(target) - for [e,:c] in terms repeat - prod := SPADCALL(SPADCALL(x,e,expn), - Mp2MpAux0(c,S,target,vars,plus,times,expn),times) - sum := SPADCALL(sum,prod,plus) - sum - -Mp2MpAux1(u,S,target,varl1,varl2,plus,monom) == - -- for case when source vars are all in target - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - [.,var,:terms] := u - sum := domainZero(target) - for [e,:c] in terms repeat - mon := SPADCALL( Mp2MpAux1(c,S,target,varl1,varl2,plus,monom), - position1(varl1.(var-1), varl2),e,monom) - sum := SPADCALL(sum,mon,plus) - sum - -Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) == - -- target vars are all in source - mp2 := ['MultivariatePolynomial,oldcomm,['MultivariatePolynomial, - oldrest,S]] - common => - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),mp2)) or coercionFailure() - objValUnwrap(u') - [var,:common] := common - u' := SPADCALL(u,position1(var,x),univariate) - null(rest(u')) and (first(first(u')) = 0) => - Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) - [1,position1(var,oldcomm),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, - common,restvars,univariate,S,isUnder)] for [e,:c] in u']] - null isUnder => - [0,:Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,true)] - -- just treat like elt of [mp,x',S] - u is [ =0,:c] => u - [var,:restvars] := restvars - u' := SPADCALL(u,position1(var,x),univariate) - null(rest(u')) and (first(first(u')) = 0) => - Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) - [1,position1(var,oldrest),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, - common,restvars,univariate,S,isUnder)] for [e,:c] in u']] - -genMpFromDmpTerm(u, oldlen) == - - -- given one term of a DMP representation of a polynomial, this creates - -- the corresponding MP term. - - patlen := oldlen - [e,:c] := u - numexps := # e - patlen >= numexps => [0, :c] - for i in patlen..(numexps - 1) repeat - e.i = 0 => patlen := patlen + 1 - return nil - patlen >= numexps => [0, :c] - [1, 1+patlen, [e.patlen,:genMpFromDmpTerm(u,patlen+1)]] - -Mp2P(u, source is [mp,vl, S], target is [p,R]) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - S is ['Polynomial,.] => MpP2P(u,vl,S,R) - vl' := REVERSE MSORT vl - -- if Mp2Mp fails, a THROW will occur - u' := Mp2Mp(u,source,[mp,vl',S]) - u' := translateMpVars2PVars (u',vl') - (u' := coerceInt(objNewWrap(u',[p,S]),target)) or coercionFailure() - objValUnwrap(u') - -MpP2P(u,vl,PS,R) == - -- u has type MP(vl,PS). Want to coerce to P R. - PR := ['Polynomial,R] - u is [ =0,:c] => - (u' :=coerceInt(objNewWrap(c,PS),PR)) or - coercionFailure() - objValUnwrap u' - [ .,pos,:ec] := u - multivariate := getFunctionFromDomain('multivariate, - PR,[['SparseUnivariatePolynomial,PR],$Symbol]) - sup := [[e,:MpP2P(c,vl,PS,R)] for [e,:c] in ec] - p := SPADCALL(sup,vl.(pos-1),multivariate) - --(p' :=coerceInt(objNewWrap(p,PS),['Polynomial,R])) or coercionFailure() - --objValUnwrap(p') - -Mp2Up(u,source is [mp,vl,S],target is [up,x,T]) == - u = '_$fromCoerceable_$ => - member(x,vl) => - vl = [x] => canCoerce(S,T) - canCoerce([mp,DELETE(x,vl),S],T) - canCoerce(source,T) - - u is [ =0,:c] => -- constant polynomial? - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap u' - - null MEMBER(x,vl) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap(u')]] - - vl = [x] => - u' := [[e,:c] for [e,.,:c] in CDDR u] - (u' := coerceInt(objNewWrap(u',[up,x,S]),target)) - or coercionFailure() - objValUnwrap u' - - -- do a univariate to transform u to a UP(x,P S) and then coerce again - var := position1(x,vl) - UPP := ['UnivariatePolynomial,x,source] - univariate := getFunctionFromDomain('univariate, - source,[source,['OrderedVariableList,vl]]) - upU := SPADCALL(u,var,univariate) -- we may assume this has type UPP - (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() - objValUnwrap u' - ---% OrderedVariableList - -OV2OV(u,source is [.,svl], target is [.,tvl]) == - svl = INTERSECTION(svl,tvl) => - u = '_$fromCoerceable_$ => true - position1(svl.(u-1),tvl) - u = '_$fromCoerceable_$ => nil - coercionFailure() - -OV2P(u,source is [.,svl], target is [.,T]) == - u = '_$fromCoerceable_$ => true - v := svl.(unwrap(u)-1) - [1,v,[1,0,:domainOne(T)]] - -OV2poly(u,source is [.,svl], target is [p,vl,T]) == - u = '_$fromCoerceable_$ => - p = 'UnivariatePolynomial => (# svl = 1) and (p = svl.0) - and/[MEMBER(v,vl) for v in svl] - v := svl.(unwrap(u)-1) - val' := [1,:domainOne(T)] - p = 'UnivariatePolynomial => - v ^= vl => coercionFailure() - [[1,:domainOne(T)]] - null MEMBER(v,vl) => coercionFailure() - val' := [[1,:domainOne(T)]] - source' := ['UnivariatePolynomial,v,T] - (u' := coerceInt(objNewWrap(val',source'),target)) or - coercionFailure() - objValUnwrap(u') - -OV2SE(u,source is [.,svl], target) == - u = '_$fromCoerceable_$ => true - svl.(unwrap(u)-1) - -OV2Sy(u,source is [.,svl], target) == - u = '_$fromCoerceable_$ => true - svl.(unwrap(u)-1) - ---% Polynomial - -varsInPoly(u) == - u is [ =1, v, :termlist] => - [v,:varsInPoly(c) for [e,:c] in termlist] - nil - -P2FR(u,S is [.,R],[.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => - ['MultivariateFactorize,$Symbol,['IndexedExponents, $Symbol],R,S] - R is ['Fraction, D] => - package := ['MRationalFactorize,['IndexedExponents, $Symbol],$Symbol, - D, S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -P2Dmp(u, source is [., S], target is [., y, T]) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(source,T) - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - plus := getFunctionFromDomain("+",target,[target,target]) - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,y],$NonNegativeInteger]) - P2DmpAux(u,source,S,target,copy y,y,T,univariate,plus,monom) - -P2Expr(u, source is [.,S], target is [., T]) == - u = '_$fromCoerceable_$ => - canCoerce(S, T) - S = T => coercionFailure() - newS := ['Polynomial, T] - val := coerceInt(objNewWrap(u, source), newS) - null val => coercionFailure() - val := coerceInt(val, target) - null val => coercionFailure() - objValUnwrap val - -P2DmpAux(u,source,S,target,varlist,vars,T,univariate,plus,monom) == - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - -- if no variables left, try to go to underdomain of target (T) - null vars => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - -- if successful, embed - (u' := coerceByFunction(u',target)) or coercionFailure() - objValUnwrap(u') - - -- there are variables, so get them out of u - [x,:vars] := vars - sup := SPADCALL(u,x,univariate) -- this is a SUP P S - null sup => -- zero? unlikely. - domainZero(target) - -- degree 0 polynomial? (variable did not occur) - null(rest(sup)) and first(sup) is [ =0,:c] => - -- call again, but with one less var - P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom) - var := position1(x,varlist) - u' := domainZero(target) - for [e,:c] in sup repeat - u'' := SPADCALL( - P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom), - var,e,monom) - u' := SPADCALL(u',u'',plus) - u' - -P2Mp(u, source is [., S], target is [., y, T]) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(source,T) - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - P2MpAux(u,source,S,target,copy y,y,T,univariate) - -P2MpAux(u,source,S,target,varlist,vars,T,univariate) == - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or - coercionFailure() - objValUnwrap(u') - - -- if no variables left, try to go to underdomain of target (T) - null vars => - (u' := coerceInt(objNewWrap(u,source),T)) or - coercionFailure() - -- if successful, embed - [ 0,:objValUnwrap(u')] - - -- there are variables, so get them out of u - [x,:vars] := vars - sup := SPADCALL(u,x,univariate) -- this is a SUP P S - null sup => -- zero? unlikely. - domainZero(target) - -- degree 0 polynomial? (variable did not occur) - null(rest(sup)) and first(sup) is [ =0,:c] => - -- call again, but with one less var - P2MpAux(c,source,S,target,varlist,vars,T,univariate) - terms := [[e,:P2MpAux(c,source,S,target,varlist,vars,T,univariate)] for - [e,:c] in sup] - [1, position1(x,varlist), :terms] - -varIsOnlyVarInPoly(u, var) == - u is [ =1, v, :termlist] => - v ^= var => nil - and/[varIsOnlyVarInPoly(c,var) for [e,:c] in termlist] - true - -P2Up(u,source is [.,S],target is [.,x,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - -- see if the target var is the polynomial vars - varsFun := getFunctionFromDomain('variables,source,[source]) - vars := SPADCALL(u,varsFun) - not MEMBER(x,vars) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap(u')]] - - -- do a univariate to transform u to a UP(x,P S) and then coerce again - UPP := ['UnivariatePolynomial,x,source] - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - upU := SPADCALL(u,x,univariate) -- we may assume this has type UPP - (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() - objValUnwrap(u') - ---% Fraction - -Qf2PF(u,source is [.,D],target) == - u = '_$fromCoerceable_$ => canCoerce(D,target) - [num,:den] := u - num':= coerceInt(objNewWrap(num,D),target) or - coercionFailure() - num' := objValUnwrap num' - den':= coerceInt(objNewWrap(den,D),target) or - coercionFailure() - den' := objValUnwrap den' - equalZero(den', target) => throwKeyedMsg("S2IA0001",NIL) - SPADCALL(num',den', getFunctionFromDomain("/",target,[target,target])) - -Qf2F(u,source is [.,D,:.],target) == - D = $Integer => - u = '_$fromCoerceable_$ => true - Rn2F(u,source,target) - u = '_$fromCoerceable_$ => canCoerce(D,target) - [num,:den] := u - [.,:num']:= coerceInt(objNewWrap(num,D),target) or - coercionFailure() - [.,:den']:= coerceInt(objNewWrap(den,D),target) or - coercionFailure() - (unwrap num') * 1.0 / (unwrap den') - -Rn2F(rnum, source, target) == - float(CAR(rnum)/CDR(rnum)) - --- next function is needed in RN algebra code ---Rn2F([a,:b],source,target) == --- al:=if LINTP a then QLENGTHCODE a else 4 --- bl:=if LINTP b then QLENGTHCODE b else 4 --- MAX(al,bl) < 36 => FLOAT a / FLOAT b --- sl:=0 --- if al>32 then --- sl:=35*(al-32)/4 --- a:=a/2**sl --- if bl>32 then --- sbl:=35*(bl-32)/4 --- b:=b/2**sbl --- sl:=sl-sbl --- ans:=FLOAT a /FLOAT b --- sl=0 => ans --- ans*2**sl - -Qf2domain(u,source is [.,D],target) == - -- tests whether it is an element of the underlying domain - useUnder := (ut := underDomainOf target) and canCoerce(source,ut) - u = '_$fromCoerceable_$ => useUnder - not (containsPolynomial(D) and containsPolynomial(target)) and - useUnder => coercionFailure() -- let other mechanism handle it - [num, :den] := u - (num' := coerceInt(objNewWrap(num,D),target)) or coercionFailure() - num' := objValUnwrap(num') - equalOne(den,D) => num' - (target is [.,[=$QuotientField,T]]) or - (target is [.,.,[=$QuotientField,T]]) => - (den' := coerceInt(objNewWrap(den,D),T)) or coercionFailure() - den' := [domainOne(T),:objValUnwrap(den')] - timesfunc:= getFunctionFromDomain('_*,target, - [[$QuotientField,T],target]) - SPADCALL(den',num',timesfunc) - coercionFailure() - -Qf2EF(u,[.,S],target) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - [num,:den] := u - (num' := coerceInt(objNewWrap(num,S),target)) or - coercionFailure() - (den' := coerceInt(objNewWrap(den,S),target)) or - coercionFailure() - divfun := getFunctionFromDomain("/",target,[target,target]) - SPADCALL(objValUnwrap(num'),objValUnwrap(den'),divfun) - -Qf2Qf(u0,[.,S],target is [.,T]) == - u0 = '_$fromCoerceable_$ => - S = ['Polynomial, [$QuotientField, $Integer]] and - T = '(Polynomial (Integer)) => true - canCoerce(S,T) - [a,:b] := u0 - S = ['Polynomial, [$QuotientField, $Integer]] and - T = '(Polynomial (Integer)) => - (a' := coerceInt(objNewWrap(a,S),target)) => - (b' := coerceInt(objNewWrap(b,S),target)) => - divfunc:= getFunctionFromDomain('_/,target,[target,target]) - SPADCALL(objValUnwrap(a'),objValUnwrap(b'),divfunc) - coercionFailure() - coercionFailure() - (a' := coerceInt(objNewWrap(a,S),T)) => - (b' := coerceInt(objNewWrap(b,S),T)) => - [objValUnwrap(a'),:objValUnwrap(b')] - coercionFailure() - coercionFailure() - --- partOf(x,i) == --- VECP x => x.i --- i=0 => first x --- i=1 => rest x --- systemError '"partOf" - ---% RectangularMatrix - -Rm2L(x,[.,.,.,R],target) == M2L(x,['Matrix,R],target) - -Rm2M(x,[.,.,.,R],target is [.,S]) == M2M(x,[nil,R],target) - -Rm2Sm(x,[.,n,m,S],[.,p,R]) == - x = '_$fromCoerceable_$ => n=m and m=p and canCoerce(S,R) - n=m and m=p => - M2M(x,[nil,S],[nil,R]) - coercionFailure() - -Rm2V(x,[.,.,.,R],target) == M2V(x,['Matrix,R],target) - ---% Script - -Scr2Scr(u, source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S,T) - null (v := coerceInt(objNewWrap(CDR u,S),T)) => - coercionFailure() - [CAR u, :objValUnwrap(v)] - ---% SparseUnivariatePolynomialnimial - -SUP2Up(u,source is [.,S],target is [.,x,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) - null u => u - S = T => u - -- try to go underneath first - null (u' := coerceInt(objNewWrap(u,source),T)) => - -- must be careful in case any of the coeffs come back 0 - u' := NIL - zero := getConstantFromDomain('(Zero),T) - for [e,:c] in u repeat - c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or - coercionFailure()) - c' = zero => 'iterate - u' := [[e,:c'],:u'] - nreverse u' - [[0,:objValUnwrap u']] - ---% SquareMatrix - -Sm2L(x,[.,.,R],target) == M2L(x,['Matrix,R],target) - -Sm2M(x,[.,n,R],target is [.,S]) == M2M(x,[nil,R],target) - -Sm2PolyType(u,source is [sm,n,S], target is [pol,vl,T]) == - -- only really handles cases like: - -- SM[2] P I -> P[x,y] SM[2] P I - -- works for UP, MP, DMP and NDMP - u = '_$fromCoerceable_$ => canCoerce(source,T) - -- first want to check case S is Polynomial - S is ['Polynomial,S'] => - -- check to see if variable occurs in any of the terms - if ATOM vl - then vl' := [vl] - else vl' := vl - novars := true - for i in 0..(n-1) while novars repeat - for j in 0..(n-1) while novars repeat - varsUsed := varsInPoly u.i.j - or/[MEMBER(x,varsUsed) for x in vl'] => novars := nil - novars => coercionFailure() - source' := [sm,n,[pol,vl,S]] - null (u' := coerceInt(objNewWrap(u,source),source')) => - coercionFailure() - null (u' := coerceInt(u',target)) => - coercionFailure() - objValUnwrap(u') - -- let other cases be handled by standard machinery - coercionFailure() - -Sm2Rm(x,[.,n,R],[.,p,q,S]) == - x = '_$fromCoerceable_$ => p=q and p=n and canCoerce(R,S) - p=q and p=n => - M2M(x,[nil,R],[nil,S]) - coercionFailure() - -Sm2V(x,[.,.,R],target) == M2V(x,['Matrix,R],target) - ---% Symbol - -Sy2OV(u,source,target is [.,vl]) == - u = '_$fromCoerceable_$ => nil - position1(u,vl) - -Sy2Dmp(u,source,target is [dmp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - len:= #vl - -1^=(n:= position(u,vl)) => - u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] - objValUnwrap(coerceInt(objNew(u,[dmp,vl,$Integer]),target)) - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Sy2Mp(u,source,target is [mp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - (n:= position1(u,vl)) ^= 0 => - [1,n,[1,0,:domainOne(S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [0,:objValUnwrap(u)] - -Sy2NDmp(u,source,target is [ndmp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - len:= #vl - -1^=(n:= position(u,vl)) => - u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] - objValUnwrap(coerceInt(objNew(u,[ndmp,vl,$Integer]),target)) - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap(u)]] - -Sy2P(u,source,target is [poly,S]) == - u = '_$fromCoerceable_$ => true - -- first try to get it into an underdomain - if (S ^= $Integer) then - u' := coerceInt(objNewWrap(u,source),S) - if u' then return [0,:objValUnwrap(u')] - -- if that failed, return it as a polynomial variable - [1,u,[1,0,:domainOne(S)]] - -Sy2Up(u,source,target is [up,x,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - u=x => [[1,:domainOne(S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Sy2Var(u,source,target is [.,x]) == - u = '_$fromCoerceable_$ => NIL - u=x => u - coercionFailure() - ---% Univariate Polynomial - -Up2Dmp(u,source is ['UnivariatePolynomial,var,S], - target is ['DistributedMultivariatePolynomial,vl,T]) == - -- var must be a member of vl, or u is a constant - u = '_$fromCoerceable_$ => MEMBER(var,vl) and canCoerce(S,target) - null u => domainZero(target) - u is [[e,:c]] and e=0 => - z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) - coercionFailure() - MEMBER(var,vl) => - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - n:= #vl ; p:= POSN1(var,vl) - l1:= not (p=0) and [0 for m in 1..p] - l2:= not (p=n-1) and [0 for m in p..n-2] - for [e,:c] in u until not z repeat - z:= coerceInt(objNewWrap(c,S),target) => - y:= SPADCALL(objValUnwrap(z), - [[LIST2VEC [:l1,e,:l2],:one]],multfunc) - x:= SPADCALL(x,y,plusfunc) - z => x - coercionFailure() - coercionFailure() - -Up2Expr(u,source is [up,var,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - null u => domainZero(target) - - u is [[e,:c]] and e=0 => - (z := coerceInt(objNewWrap(c, S), target)) => objValUnwrap(z) - coercionFailure() - - sym := objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) - - plus := getFunctionFromDomain("+", target, [target, target]) - mult := getFunctionFromDomain("*", target, [target, target]) - expn := getFunctionFromDomain("**", target, [target, $Integer]) - - -- coerce via Horner's rule - - [e1, :c1] := first u - if not (S = target) then - not (c1 := coerceInt(objNewWrap(c1, S), target)) => coercionFailure() - c1 := objValUnwrap(c1) - - for [e2, :c2] in rest u repeat - coef := - e1 - e2 = 1 => sym - SPADCALL(sym, e1-e2, expn) - if not (S = target) then - not (c2 := coerceInt(objNewWrap(c2, S), target)) => - coercionFailure() - c2 := objValUnwrap(c2) - coef := SPADCALL(SPADCALL(c1, coef, mult), c2, plus) - e1 := e2 - c1 := coef - - e1 = 0 => c1 - e1 = 1 => SPADCALL(sym, c1, mult) - SPADCALL(SPADCALL(sym, e1, expn), c1, mult) - -Up2FR(u,S is [.,x,R],target is [.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => ['UnivariateFactorize,S] - R = $RationalNumber => package := ['RationalFactorize,S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Up2Mp(u,source is [.,x,S], target is [.,vl,T]) == - u = '_$fromCoerceable_$ => - MEMBER(x,vl) => canCoerce(S,T) - canCoerce(source,T) - - null u => domainZero(target) - - null(rest(u)) and (first(u) is [e,:c]) and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - - null MEMBER(x,vl) => - (x := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [0,:objValUnwrap(x)] - - plus := getFunctionFromDomain('_+,target,[target,target]) - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,vl],$NonNegativeInteger]) - sum := domainZero(target) - pos := position1(x,vl) - - for [e,:c] in u repeat - (p := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - mon := SPADCALL(objValUnwrap(p),pos,e,monom) - sum := SPADCALL(sum,mon,plus) - sum - -Up2P(u,source is [.,var,S],target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - null u => domainZero(target) - u is [[e,:c]] and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - pol:= domainZero(target) - one:= domainOne(T) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - for [e,:c] in u until not x repeat - x:= coerceInt(objNewWrap(c,S),target) => - term:= SPADCALL([1,var,[e,0,:one]],objValUnwrap(x),multfunc) - pol:= SPADCALL(pol,term,plusfunc) - coercionFailure() - x => pol - coercionFailure() - -Up2SUP(u,source is [.,x,S],target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) - null u => u - S = T => u - -- try to go underneath first - null (u' := coerceInt(objNewWrap(u,source),T)) => - u' := NIL - zero := getConstantFromDomain('(Zero),T) - for [e,:c] in u repeat - c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or - coercionFailure()) - c' = zero => 'iterate - u' := [[e,:c'],:u'] - nreverse u' - [[0,:objValUnwrap u']] - -Up2Up(u,source is [.,v1,S], target is [.,v2,T]) == - -- if v1 = v2 then this is handled by coerceIntByMap - -- this only handles case where poly is a constant - u = '_$fromCoerceable_$ => - v1=v2 => canCoerce(S,T) - canCoerce(source,T) - null u => u - u is [[e,:c]] and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - coercionFailure() - -insertAlist(a,b,l) == - null l => [[a,:b]] - a = l.0.0 => (RPLAC(CDAR l,b);l) - _?ORDER(l.0.0,a) => [[a,:b],:l] - (fn(a,b,l);l) where fn(a,b,l) == - null rest l => RPLAC(rest l,[[a,:b]]) - a = l.1.0 => RPLAC(rest l.1,b) - _?ORDER(l.1.0,a) => RPLAC(rest l,[[a,:b],:rest l]) - fn(a,b,rest l) - ---% Union - -Un2E(x,source,target) == - ['Union,:branches] := source - x = '_$fromCoerceable_$ => - and/[canCoerce(t, target) for t in branches | ^ STRINGP t] - coerceUn2E(x,source) - ---% Variable - -Var2OV(u,source,target is [.,vl]) == - sym := CADR source - u = '_$fromCoerceable_$ => MEMBER(sym,vl) - MEMBER(sym,vl) => position1(sym,vl) - coercionFailure() - -Var2Dmp(u,source,target is [dmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) - - len := #vl - -1 ^= (n:= position(sym,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Var2Gdmp(u,source,target is [dmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) - - len := #vl - -1 ^= (n:= position(sym,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Var2Mp(u,source,target is [mp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) - (n:= position1(u,vl)) ^= 0 => - [1,n,[1,0,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [0,:objValUnwrap u] - -Var2NDmp(u,source,target is [ndmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) - - len:= #vl - -1^=(n:= position(u,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap(u)]] - -Var2P(u,source,target is [poly,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => true - - -- first try to get it into an underdomain - if (S ^= $Integer) then - u' := coerceInt(objNewWrap(u,source),S) - if u' then return [0,:objValUnwrap(u')] - -- if that failed, return it as a polynomial variable - [1,sym,[1,0,:getConstantFromDomain('(One),S)]] - -Var2QF(u,source,target is [qf,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - - S = $Integer => coercionFailure() - sym := CADR source - (u' := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [objValUnwrap u',:getConstantFromDomain('(One),S)] - -Var2FS(u,source,target is [fs,S]) == - u = '_$fromCoerceable_$ => true - (v := coerceInt(objNewWrap(u,source),['Polynomial,S])) or - coercionFailure() - (v := coerceInt(v,target)) or coercionFailure() - objValUnwrap v - -Var2Up(u,source,target is [up,x,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) - - x=sym => [[1,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Var2SUP(u,source,target is [sup,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = "?") or canCoerce(source,S) - - sym = "?" => [[1,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Var2UpS(u,source,target is [ups,x,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) - - mid := ['UnivariatePolynomial,x,S] - x = sym => - u := Var2Up(u,source,mid) - (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() - objValUnwrap u - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Var2OtherPS(u,source,target is [.,x,S]) == - sym := CADR source - mid := ['UnivariatePowerSeries,x,S] - u = '_$fromCoerceable_$ => - (sym = x) or (canCoerce(source,mid) and canCoerce(mid,target)) - u := Var2UpS(u,source,mid) - (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() - objValUnwrap u - ---% Vector - -V2M(u,[.,D],[.,R]) == - u = '_$fromCoerceable_$ => - D is ['Vector,:.] => nil -- don't have data - canCoerce(D,R) - -- first see if we are coercing a vector of vectors - D is ['Vector,E] and - isRectangularVector(u,MAXINDEX u,MAXINDEX u.0) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - -- if not, try making it into a 1 by n matrix - coercionFailure() ---LIST2VEC [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(u.i,D),R)) --- for i in 0..MAXINDEX(u)]] - -V2Rm(u,[.,D],[.,n,m,R]) == - u = '_$fromCoerceable_$ => nil - D is [.,E,:.] and isRectangularVector(u,n-1,m-1) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - coercionFailure() - -V2Sm(u,[.,D],[.,n,R]) == - u = '_$fromCoerceable_$ => nil - D is [.,E,:.] and isRectangularVector(u,n-1,n-1) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - coercionFailure() - -isRectangularVector(x,p,q) == - MAXINDEX x = p => - and/[q=MAXINDEX x.i for i in 0..p] - --- Polynomial and Expression to Univariate series types - -P2Uts(u, source, target) == - P2Us(u,source, target, 'taylor) - -P2Uls(u, source, target) == - P2Us(u,source, target, 'laurent) - -P2Upxs(u, source, target) == - P2Us(u,source, target, 'puiseux) - -P2Us(u, source is [.,S], target is [.,T,var,cen], type) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(S,T) - T isnt ['Expression, :.] => coercionFailure() - if S ^= '(Float) then S := $Integer - obj := objNewWrap(u, source) - E := ['Expression, S] - newU := coerceInt(obj, E) - null newU => coercionFailure() - EQtype := ['Equation, E] - eqfun := getFunctionFromDomain('_=, EQtype, [E,E]) - varE := coerceInt(objNewWrap(var, '(Symbol)), E) - null varE => coercionFailure() - cenE := coerceInt(objNewWrap(cen, T), E) - null cenE => coercionFailure() - eq := SPADCALL(objValUnwrap(varE), objValUnwrap(cenE), eqfun) - package := ['ExpressionToUnivariatePowerSeries, S, E] - func := getFunctionFromDomain(type, package, [E, EQtype]) - newObj := SPADCALL(objValUnwrap(newU), eq, func) - newType := CAR newObj - newVal := CDR newObj - newType = target => newVal - finalObj := coerceInt(objNewWrap(newVal, newType), target) - null finalObj => coercionFailure() - objValUnwrap finalObj - - ---% General Coercion Commutation Functions - --- general commutation functions are called with 5 values --- u object of type source --- source type of u --- S underdomain of source --- target coercion target type --- T underdomain of T --- Because of checking, can always assume S and T have underdomains. - ---% Complex - -commuteComplex(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - [real,:imag] := u - (real := coerceInt(objNewWrap(real,S),target)) or coercionFailure() - (imag := coerceInt(objNewWrap(imag,S),target)) or coercionFailure() - T' := underDomainOf T - i := [domainZero(T'), - :domainOne(T')] - (i := coerceInt(objNewWrap(i,T),target)) or coercionFailure() - f := getFunctionFromDomain("*",target,[target,target]) - i := SPADCALL(objValUnwrap i, objValUnwrap imag, f) - f := getFunctionFromDomain("+",target,[target,target]) - SPADCALL(objValUnwrap real,i,f) - ---% Quaternion - -commuteQuaternion(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - c := [objValUnwrap(coerceInt(objNewWrap(x,S),target) - or coercionFailure()) for x in VEC2LIST u] - q := '(Quaternion (Integer)) - e := [[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]] - e := [(coerceInt(objNewWrap(LIST2VEC x,q),T) - or coercionFailure()) for x in e] - e :=[objValUnwrap(coerceInt(x,target) or coercionFailure()) for x in e] - u' := domainZero(target) - mult := getFunctionFromDomain("*",target,[target,target]) - plus := getFunctionFromDomain("+",target,[target,target]) - for x in c for y in e repeat - u' := SPADCALL(u',SPADCALL(x,y,mult),plus) - u' - ---% Fraction - -commuteFraction(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - ofCategory(target,'(Field)) => canCoerce(S,target) - canCoerce(S,T) and canCoerce(T,target) - [n,:d] := u - ofCategory(target,'(Field)) => - -- see if denominator can go over to target - (d' := coerceInt(objNewWrap(d,S),target)) or coercionFailure() - -- if so, try to invert it - inv := getFunctionFromDomain('inv,target,[target]) - d' := SPADCALL(objValUnwrap d',inv) - -- now coerce to target - (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() - multfunc := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(d',objValUnwrap n',multfunc) - -- see if denominator can go over to QF part of target - (d' := coerceInt(objNewWrap(d,S),T)) or coercionFailure() - -- if so, try to invert it - inv := getFunctionFromDomain('inv,T,[T]) - d' := SPADCALL(objValUnwrap d',inv) - -- now coerce to target - (d' := coerceInt(objNewWrap(d',T),target)) or coercionFailure() - (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() - multfunc := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(objValUnwrap d',objValUnwrap n',multfunc) - ---% SquareMatrix - -commuteSquareMatrix(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - -- commuting matrices of matrices should be a no-op - S is ['SquareMatrix,:.] => - source=target => u - coercionFailure() - u' := domainZero(target) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - zero := domainZero(S) - [sm,n,:.] := source - S' := [sm,n,$Integer] - for i in 0..(n-1) repeat - for j in 0..(n-1) repeat - (e := u.i.j) = zero => 'iterate - (e' := coerceInt(objNewWrap(e,S),target)) or coercionFailure() - (Eij := coerceInt(objNewWrap(makeEijSquareMatrix(i,j,n),S'),T)) or - coercionFailure() - (Eij := coerceInt(Eij,target)) or coercionFailure() - e' := SPADCALL(objValUnwrap(e'),objValUnwrap(Eij),multfunc) - u' := SPADCALL(e',u',plusfunc) - u' - -makeEijSquareMatrix(i, j, dim) == - -- assume using 0 based scale, makes a dim by dim matrix with a - -- 1 in the i,j position, zeros elsewhere - LIST2VEC [LIST2VEC [((i=r) and (j=c) => 1; 0) - for c in 0..(dim-1)] for r in 0..(dim-1)] - ---% Univariate Polynomial and Sparse Univariate Polynomial - -commuteUnivariatePolynomial(u,source,S,target,T) == - commuteSparseUnivariatePolynomial(u,source,S,target,T) - -commuteSparseUnivariatePolynomial(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - - u' := domainZero(target) - null u => u' - - T' := underDomainOf T - one := domainOne(T') - monom := getFunctionFromDomain('monomial,T,[T',$NonNegativeInteger]) - plus := getFunctionFromDomain("+",target,[target,target]) - times := getFunctionFromDomain("*",target,[target,target]) - - for [e,:c] in u repeat - (c := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - m := SPADCALL(one,e,monom) - (m := coerceInt(objNewWrap(m,T),target)) or coercionFailure() - c := objValUnwrap c - m := objValUnwrap m - u' := SPADCALL(u',SPADCALL(c,m,times),plus) - u' - ---% Multivariate Polynomials - -commutePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteDistributedMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteNewDistributedMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteMPolyCat(u,source,S,target,T) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - -- check constant case - isconstfun := getFunctionFromDomain("ground?",source,[source]) - SPADCALL(u,isconstfun) => - constfun := getFunctionFromDomain("ground",source,[source]) - c := SPADCALL(u,constfun) - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - lmfun := getFunctionFromDomain('leadingMonomial,source,[source]) - lm := SPADCALL(u,lmfun) -- has type source, is leading monom - - lcfun := getFunctionFromDomain('leadingCoefficient,source,[source]) - lc := SPADCALL(lm,lcfun) -- has type S, is leading coef - (lc' := coerceInt(objNewWrap(lc,S),target)) or coercionFailure() - - pmfun := getFunctionFromDomain('primitiveMonomials,source,[source]) - lm := first SPADCALL(lm,pmfun) -- now we have removed the leading coef - (lm' := coerceInt(objNewWrap(lm,source),T)) or coercionFailure() - (lm' := coerceInt(lm',target)) or coercionFailure() - - rdfun := getFunctionFromDomain('reductum,source,[source]) - rd := SPADCALL(u,rdfun) -- has type source, is reductum - (rd' := coerceInt(objNewWrap(rd,source),target)) or coercionFailure() - - lc' := objValUnwrap lc' - lm' := objValUnwrap lm' - rd' := objValUnwrap rd' - - plusfun := getFunctionFromDomain("+",target,[target,target]) - multfun := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(SPADCALL(lc',lm',multfun),rd',plusfun) - ------------------------------------------------------------------------- --- Format for alist member is: domain coercionType function --- here coercionType can be one of 'total, 'partial or 'indeterm --- (indeterminant - cannot tell in a simple way). --- --- In terms of canCoerceFrom, 'total implies true, 'partial implies --- false (just cannot tell without actual data) and 'indeterm means --- to call the function with the data = "$fromCoerceable$" for a --- response of true or false. ------------------------------------------------------------------------- --- There are no entries here for RationalNumber or RationalFunction. --- These should have been changed to QF I and QF P, respectively, by --- a function like deconstructTower. RSS 8-1-85 ------------------------------------------------------------------------- - -SETANDFILEQ($CoerceTable, '( _ - (Complex . ( _ - (Expression indeterm Complex2Expr) _ - (Factored indeterm Complex2FR) _ - (Integer partial Complex2underDomain) _ - (PrimeField partial Complex2underDomain) _ - ))_ - (DirectProduct . ( _ - (DirectProduct partial DP2DP) _ - )) _ - (DistributedMultivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Dmp2Dmp) _ - (Expression indeterm Dmp2Expr) _ - (Factored indeterm Mp2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Dmp2NDmp) _ - (MultivariatePolynomial indeterm Dmp2Mp) _ - (Polynomial indeterm Dmp2P) _ - (UnivariatePolynomial indeterm Dmp2Up) _ - ))_ - (Expression . ( - (Complex partial Expr2Complex) _ - (DistributedMultivariatePolynomial indeterm Expr2Dmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Expr2Dmp) _ - (MultivariatePolynomial indeterm Expr2Mp) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial indeterm Expr2Up) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - )) _ - - (Kernel . ( _ - (Kernel indeterm Ker2Ker) _ - (Expression indeterm Ker2Expr) _ - )) _ - - (Factored . ( _ - (Factored indeterm Factored2Factored) _ - ))_ - (Fraction . ( _ - (DistributedMultivariatePolynomial partial Qf2domain) _ - (ElementaryFunction indeterm Qf2EF) _ - (Expression indeterm Qf2EF) _ - (Fraction indeterm Qf2Qf) _ - (HomogeneousDistributedMultivariatePolynomial partial Qf2domain) _ - (Integer partial Qf2domain) _ - (MultivariatePolynomial partial Qf2domain) _ - (Polynomial partial Qf2domain) _ - (PrimeField indeterm Qf2PF) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial partial Qf2domain) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - ))_ - (Int . ( _ - (Expression total ncI2E) _ - (Integer total ncI2I) _ - ))_ - (Baby . ( _ - (Expression total ncI2E) _ - (Integer total ncI2I) _ - ))_ - (Integer . ( _ - (Baby total I2ncI) _ - (EvenInteger partial I2EI) _ - (Int total I2ncI) _ - (NonNegativeInteger partial I2NNI) _ - (OddInteger partial I2OI) _ - (PositiveInteger partial I2PI) _ - ))_ - (List . ( _ - (DirectProduct indeterm L2DP) _ - (Matrix partial L2M) _ - (Record partial L2Record) _ - (RectangularMatrix partial L2Rm) _ - (Set indeterm L2Set) _ - (SquareMatrix partial L2Sm) _ - (Stream indeterm Agg2Agg) _ - (Tuple indeterm L2Tuple) _ - (Vector indeterm L2V) _ - ))_ - )) - -SETANDFILEQ($CoerceTable,NCONC($CoerceTable,'( _ - (Matrix . ( _ - (List indeterm M2L) _ - (RectangularMatrix partial M2Rm) _ - (SquareMatrix partial M2Sm) _ - (Vector indeterm M2L) _ - ))_ - (MultivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Mp2Dmp) _ - (Expression indeterm Mp2Expr) _ - (Factored indeterm Mp2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ - (MultivariatePolynomial indeterm Mp2Mp) _ - (Polynomial indeterm Mp2P) _ - (UnivariatePolynomial indeterm Mp2Up) _ - ))_ - (HomogeneousDirectProduct . ( _ - (HomogeneousDirectProduct indeterm DP2DP) _ - ))_ - (HomogeneousDistributedMultivariatePolynomial . ( _ - (Complex indeterm NDmp2domain) _ - (DistributedMultivariatePolynomial indeterm NDmp2domain) _ - (Expression indeterm Dmp2Expr) _ - (Factored indeterm Mp2FR) _ - (Fraction indeterm NDmp2domain) _ - (HomogeneousDistributedMultivariatePolynomial indeterm NDmp2NDmp) _ - (MultivariatePolynomial indeterm NDmp2domain) _ - (Polynomial indeterm NDmp2domain) _ - (Quaternion indeterm NDmp2domain) _ - (UnivariatePolynomial indeterm NDmp2domain) _ - ))_ - (OrderedVariableList . ( _ - (DistributedMultivariatePolynomial indeterm OV2poly) _ - (HomogeneousDistributedMultivariatePolynomial indeterm OV2poly) _ - (MultivariatePolynomial indeterm OV2poly) _ - (OrderedVariableList indeterm OV2OV) _ - (Polynomial total OV2P) _ - (Symbol total OV2Sy) _ - (UnivariatePolynomial indeterm OV2poly) _ - ))_ - (Polynomial . ( _ - (DistributedMultivariatePolynomial indeterm P2Dmp) _ - (Expression indeterm P2Expr) _ - (Factored indeterm P2FR) _ - (HomogeneousDistributedMultivariatePolynomial partial domain2NDmp) _ - (MultivariatePolynomial indeterm P2Mp) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial indeterm P2Up) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - ))_ - (Set . ( _ - (List indeterm Set2L) _ - (Vector indeterm Agg2L2Agg) _ - ))_ - (RectangularMatrix . ( _ - (List indeterm Rm2L) _ - (Matrix indeterm Rm2M) _ - (SquareMatrix indeterm Rm2Sm) _ - (Vector indeterm Rm2V) _ - ))_ - (SparseUnivariatePolynomial . ( _ - (UnivariatePolynomial indeterm SUP2Up) _ - ))_ - (SquareMatrix . ( - -- ones for polys needed for M[2] P I -> P[x,y] M[2] P I, say - (DistributedMultivariatePolynomial partial Sm2PolyType) _ - (HomogeneousDistributedMultivariatePolynomial partial Sm2PolyType) _ - (List indeterm Sm2L) _ - (Matrix indeterm Sm2M) _ - (MultivariatePolynomial partial Sm2PolyType) _ - (RectangularMatrix indeterm Sm2Rm) _ - (UnivariatePolynomial indeterm Sm2PolyType) _ - (Vector indeterm Sm2V) _ - ) ) _ - (Symbol . ( _ - (DistributedMultivariatePolynomial indeterm Sy2Dmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Sy2NDmp) _ - (MultivariatePolynomial indeterm Sy2Mp) _ - (OrderedVariableList partial Sy2OV) _ - (Polynomial total Sy2P) _ - (UnivariatePolynomial indeterm Sy2Up) _ - (Variable indeterm Sy2Var) _ - ) ) _ - (UnivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Up2Dmp) _ - (Expression indeterm Up2Expr) _ - (Factored indeterm Up2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ - (MultivariatePolynomial indeterm Up2Mp) _ - (Polynomial indeterm Up2P) _ - (SparseUnivariatePolynomial indeterm Up2SUP) _ - (UnivariatePolynomial indeterm Up2Up) _ - ) ) _ - (Variable . ( _ - (AlgebraicFunction total Var2FS) _ - (ContinuedFractionPowerSeries indeterm Var2OtherPS) _ - (DistributedMultivariatePolynomial indeterm Var2Dmp) _ - (ElementaryFunction total Var2FS) _ - (Fraction indeterm Var2QF) _ - (FunctionalExpression total Var2FS) _ - (GeneralDistributedMultivariatePolynomial indeterm Var2Gdmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Var2NDmp) _ - (LiouvillianFunction total Var2FS) _ - (MultivariatePolynomial indeterm Var2Mp) _ - (OrderedVariableList indeterm Var2OV) _ - (Polynomial total Var2P) _ - (SparseUnivariatePolynomial indeterm Var2SUP) _ - (Symbol total Identity) _ - (UnivariatePolynomial indeterm Var2Up) _ - (UnivariatePowerSeries indeterm Var2UpS) _ - ) ) _ - (Vector . ( _ - (DirectProduct indeterm V2DP) _ - (List indeterm V2L) _ - (Matrix indeterm V2M) _ - (RectangularMatrix indeterm V2Rm) _ - (Set indeterm Agg2L2Agg) _ - (SquareMatrix indeterm V2Sm) _ - (Stream indeterm Agg2Agg) _ - ) ) _ - ) ) ) - --- this list is too long for the parser, so it has to be split into parts --- specifies the commute functions --- commute stands for partial commute function ---SETANDFILEQ($CommuteTable, '( _ --- (DistributedMultivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Complex . ( _ --- (DistributedMultivariatePolynomial commute commuteG2) _ --- (MultivariatePolynomial commute commuteG2) _ --- (NewDistributedMultivariatePolynomial commute commuteG2) _ --- (Polynomial commute commuteG1) _ --- (Fraction commute commuteG1) _ --- (SquareMatrix commute commuteG2) _ --- (UnivariatePolynomial commute commuteG2) _ --- )) _ --- (MultivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Polynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Quaternion . ( _ --- (DistributedMultivariatePolynomial commute commuteQuat2) _ --- (MultivariatePolynomial commute commuteQuat2) _ --- (NewDistributedMultivariatePolynomial commute commuteQuat2) _ --- (Polynomial commute commuteQuat1) _ --- (SquareMatrix commute commuteQuat2) _ --- (UnivariatePolynomial commute commuteQuat2) _ --- )) _ --- (SquareMatrix . ( _ --- (DistributedMultivariatePolynomial commute commuteSm2) _ --- (Complex commute commuteSm1) _ --- (MultivariatePolynomial commute commuteSm2) _ --- (NewDistributedMultivariatePolynomial commute commuteSm2) _ --- (Polynomial commute commuteSm1) _ --- (Quaternion commute commuteSm1) _ --- (SparseUnivariatePolynomial commute commuteSm1) _ --- (UnivariatePolynomial commute commuteSm2) _ --- )) _ --- (UnivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteUp2) _ --- (Complex commute commuteUp1) _ --- (MultivariatePolynomial commute commuteUp2) _ --- (NewDistributedMultivariatePolynomial commute commuteUp2) _ --- (Polynomial commute commuteUp1) _ --- (Quaternion commute commuteUp1) _ --- (Fraction commute commuteUp1) _ --- (SparseUnivariatePolynomial commute commuteUp1) _ --- (SquareMatrix commute commuteUp2) _ --- (UnivariatePolynomial commute commuteUp2) _ --- )) _ --- )) - -SETANDFILEQ($CommuteTable, '( _ - (Complex . ( _ - (DistributedMultivariatePolynomial commute commuteG2) _ - (MultivariatePolynomial commute commuteG2) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteG2) _ - (Polynomial commute commuteG1) _ - (Fraction commute commuteG1) _ - (SquareMatrix commute commuteG2) _ - (UnivariatePolynomial commute commuteG2) _ - )) _ - (Polynomial . ( _ - (Complex commute commuteMultPol) _ - (MultivariatePolynomial commute commuteMultPol) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteMultPol)_ - (Polynomial commute commuteMultPol) _ - (Quaternion commute commuteMultPol) _ - (Fraction commute commuteMultPol) _ - (SquareMatrix commute commuteMultPol) _ - (UnivariatePolynomial commute commuteMultPol) _ - )) _ - (SquareMatrix . ( _ - (DistributedMultivariatePolynomial commute commuteSm2) _ - (Complex commute commuteSm1) _ - (MultivariatePolynomial commute commuteSm2) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteSm2)_ - (Polynomial commute commuteSm1) _ - (Quaternion commute commuteSm1) _ - (SparseUnivariatePolynomial commute commuteSm1) _ - (UnivariatePolynomial commute commuteSm2) _ - )) _ - )) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-coerfn.lisp.pamphlet b/src/interp/i-coerfn.lisp.pamphlet new file mode 100755 index 0000000..4ae277d --- /dev/null +++ b/src/interp/i-coerfn.lisp.pamphlet @@ -0,0 +1,7007 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-coerfn.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} +Special coercion routines + +This is the newly revised set of coercion functions to work with +the new library and the new runtime system. + +coerceByTable is driven off $CoerceTable which is used to match +the top-level constructors of the source and object types. The +form of $CoerceTable is an alist where the "properties" are the +source top-level constructors and the values are triples + target-domain coercion-type function +where target-domain is the top-level constructor of the target, +coercion-type is one of 'total, 'partial or 'indeterm, and +function is the name of the function to call to handle the +coercion. coercion-type is used by canCoerce and friends: 'total +means that a coercion can definitely be performed, 'partial means +that one cannot tell whether a coercion can be performed unless +you have the actual data (like telling whether a Polynomial Integer +can be coerced to an Integer: you have to know whether it is a +constant polynomial), and 'indeterm means that you might be able +to tell without data, but you need to call the function with the +argument "$fromCoerceable$" for a response of true or false. As an +example of this last kind, you may be able to coerce a list to a +vector but you have to know what the underlying types are. So +List Integer is coerceable to Vector Integer but List Float is +not necessarily coerceable to Vector Integer. + +The functions always take three arguments: + value this is the unwrapped source object + source-type this is the type of the source + target-type this is the requested type of the target +For ethical reasons and to avoid eternal damnation, we try to use +library functions to perform a lot of the structure manipulations. +However, we sometimes cheat for efficiency reasons, particularly to +avoid intermediate instantiations. + +the following are older comments: + +This file contains the special coercion routines that convert from +one datatype to another in the interpreter. The choice of the +primary special routine is made by the function coerceByTable. Note +that not all coercions use these functions, as some are done via SPAD +algebra code and controlled by the function coerceByFunction. See +the file COERCE BOOT for more information. + +some assumption about the call of commute and embed functions: +embed functions are called for one level embedding only, + e.g. I to P I, but not I to P G I +commute functions are called for two types which differ only in the + permutation of the two top type constructors + e.g. G P RN to P G RN, but not G P I to P G RN or + P[x] G RN to G P RN + +all functions in this file should call canCoerce and coerceInt, as + opposed to canCoerceFrom and coerceInteractive + +all these coercion functions have the following result: +1. if u=$fromCoerceable$, then TRUE or NIL +2. if the coercion succeeds, the coerced value (this may be NIL) +3. if the coercion fails, they throw to a catch point in + coerceByTable + +\end{verbatim} +<<*>>= +(in-package "BOOT") + +;SETANDFILEQ($coerceFailure,GENSYM()) + +(SETANDFILEQ |$coerceFailure| (GENSYM)) + +;position1(x,y) == +; -- this is used where we want to assume a 1-based index +; 1 + position(x,y) + +(DEFUN |position1| (|x| |y|) (PLUS 1 (|position| |x| |y|))) + +;--% Direct Product, New and Old +;DP2DP(u,source is [.,n,S],target is [.,m,T]) == +; n ^= m => nil +; u = '_$fromCoerceable_$ => canCoerce(S,T) +; null (u' := coerceInt(objNewWrap(u,['Vector,S]),['Vector,T])) => +; coercionFailure() +; objValUnwrap u' + +(DEFUN DP2DP (|u| |source| |target|) + (PROG (|m| T$ |n| S |u'|) + (RETURN + (PROGN + (SPADLET |m| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |n| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NEQUAL |n| |m|) NIL) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((NULL + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u| (CONS (QUOTE |Vector|) (CONS S NIL))) + (CONS (QUOTE |Vector|) (CONS T$ NIL))))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |u'|))))))) + +;--% Distributed Multivariate Polynomials, New and Old +;Dmp2Dmp(u,source is [dmp,v1,S], target is [.,v2,T]) == +; -- the variable lists must share some variables, or u is a constant +; u = '_$fromCoerceable_$ => +; v:= INTERSECTION(v1,v2) +; v and +; w2:= SETDIFFERENCE(v2,v) +; t1:= if w1 then [dmp,w1,S] else S +; t2:= if w2 then [dmp,w2,T] else T +; canCoerce(t1,t2) +; null u => domainZero(target) +; u is [[e,:c]] and e=LIST2VEC [0 for v in v1] => +; z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) +; coercionFailure() +; v:= INTERSECTION(v1,v2) => +; w1:= SETDIFFERENCE(v1,v) => +; coerceDmp1(u,source,target,v,w1) +; coerceDmp2(u,source,target) +; coercionFailure() + +(DEFUN |Dmp2Dmp| (|u| |source| |target|) + (PROG (|v2| T$ |dmp| |v1| S |w2| |t1| |t2| |ISTMP#1| |e| |c| |z| |v| |w1|) + (RETURN + (SEQ + (PROGN + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |v1| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (SPADLET |v| (|intersection| |v1| |v2|)) + (AND + |v| + (PROGN + (SPADLET |w2| (SETDIFFERENCE |v2| |v|)) + (SPADLET |t1| + (COND (|w1| (CONS |dmp| (CONS |w1| (CONS S NIL)))) ((QUOTE T) S))) + (SPADLET |t2| + (COND (|w2| (CONS |dmp| (CONS |w2| (CONS T$ NIL)))) ((QUOTE T) T$))) + (|canCoerce| |t1| |t2|)))) + ((NULL |u|) (|domainZero| |target|)) + ((AND (PAIRP |u|) + (EQ (QCDR |u|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (BOOT-EQUAL + |e| + (LIST2VEC + (PROG (#0=#:G166139) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166144 |v1| (CDR #1#)) (|v| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |v| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS 0 #0#)))))))))) + (COND + ((SPADLET |z| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |z|)) + ((QUOTE T) + (|coercionFailure|)))) + ((SPADLET |v| (|intersection| |v1| |v2|)) + (COND + ((SPADLET |w1| (SETDIFFERENCE |v1| |v|)) + (|coerceDmp1| |u| |source| |target| |v| |w1|)) + ((QUOTE T) (|coerceDmp2| |u| |source| |target|)))) + ((QUOTE T) (|coercionFailure|)))))))) + +;coerceDmp1(u,source is [.,v1,S],target is [.,v2,T],v,w) == +; -- coerces one Dmp to another, where v1 is not a subset of v2 +; -- v is the intersection, w the complement of v1 and v2 +; t:= ['DistributedMultivariatePolynomial,w,S] +; x:= domainZero(target) +; one:= domainOne(T) +; plusfunc:= getFunctionFromDomain('_+,target,[target,target]) +; multfunc:= getFunctionFromDomain('_*,target,[target,target]) +; pat1:= [MEMBER(x,v) for x in v1] +; pat2:= [MEMBER(x,w) for x in v1] +; pat3:= [MEMBER(x,v) and POSN1(x,v) for x in v2] +; for [e,:c] in u until not z repeat +; exp:= LIST2VEC [y for x in pat2 for y in VEC2LIST e | x] +; z:= coerceInt(objNewWrap([CONS(exp,c)],t),target) => +; li:= [y for x in pat1 for y in VEC2LIST e | x] +; a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat3],one)] +; x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) +; z => x +; coercionFailure() + +(DEFUN |coerceDmp1| (|u| |source| |target| |v| |w|) + (PROG (|v2| T$ |v1| S |t| |one| |plusfunc| |multfunc| |pat1| |pat2| |pat3| + |e| |c| |exp| |z| |li| |a| |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |v1| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (SPADLET |t| + (CONS + (QUOTE |DistributedMultivariatePolynomial|) + (CONS |w| (CONS S NIL)))) + (SPADLET |x| (|domainZero| |target|)) + (SPADLET |one| (|domainOne| T$)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |pat1| + (PROG (#0=#:G166206) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166211 |v1| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|member| |x| |v|) #0#)))))))) + (SPADLET |pat2| + (PROG (#2=#:G166221) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166226 |v1| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (|member| |x| |w|) #2#)))))))) + (SPADLET |pat3| + (PROG (#4=#:G166236) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G166241 |v2| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS (AND (|member| |x| |v|) (POSN1 |x| |v|)) #4#)))))))) + (DO ((#6=#:G166257 |u| (CDR #6#)) + (#7=#:G166171 NIL) + (#8=#:G166258 NIL (NULL |z|))) + ((OR (ATOM #6#) + (PROGN (SETQ #7# (CAR #6#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #7#)) (SPADLET |c| (CDR #7#)) #7#) + NIL) + #8#) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET + |exp| + (LIST2VEC + (PROG (#9=#:G166272) + (SPADLET #9# NIL) + (RETURN + (DO ((#10=#:G166279 |pat2| (CDR #10#)) + (|x| NIL) + (#11=#:G166280 (VEC2LIST |e|) (CDR #11#)) + (|y| NIL)) + ((OR (ATOM #10#) + (PROGN (SETQ |x| (CAR #10#)) NIL) + (ATOM #11#) + (PROGN (SETQ |y| (CAR #11#)) NIL)) + (NREVERSE0 #9#)) + (SEQ (EXIT (COND (|x| (SETQ #9# (CONS |y| #9#))))))))))) + (COND + ((SPADLET |z| + (|coerceInt| + (|objNewWrap| (CONS (CONS |exp| |c|) NIL) |t|) + |target|)) + (PROGN + (SPADLET + |li| + (PROG (#12=#:G166295) + (SPADLET #12# NIL) + (RETURN + (DO ((#13=#:G166302 |pat1| (CDR #13#)) + (|x| NIL) + (#14=#:G166303 (VEC2LIST |e|) (CDR #14#)) + (|y| NIL)) + ((OR (ATOM #13#) + (PROGN (SETQ |x| (CAR #13#)) NIL) + (ATOM #14#) + (PROGN (SETQ |y| (CAR #14#)) NIL)) + (NREVERSE0 #12#)) + (SEQ (EXIT (COND (|x| (SETQ #12# (CONS |y| #12#)))))))))) + (SPADLET + |a| + (CONS + (CONS + (LIST2VEC + (PROG (#15=#:G166316) + (SPADLET #15# NIL) + (RETURN + (DO ((#16=#:G166321 |pat3| (CDR #16#)) (|x| NIL)) + ((OR (ATOM #16#) (PROGN (SETQ |x| (CAR #16#)) NIL)) + (NREVERSE0 #15#)) + (SEQ + (EXIT + (SETQ #15# + (CONS + (COND (|x| (ELT |li| |x|)) ((QUOTE T) 0)) + #15#)))))))) + |one|) + NIL)) + (SPADLET |x| + (SPADCALL |x| + (SPADCALL (|objValUnwrap| |z|) |a| |multfunc|) + |plusfunc|))))))))) + (COND + (|z| |x|) + ((QUOTE T) (|coercionFailure|)))))))) +;coerceDmp2(u,source is [.,v1,S],target is [.,v2,T]) == +; -- coerces one Dmp to another, where v1 is included in v2 +; x:= domainZero(target) +; one:= domainOne(T) +; plusfunc:= getFunctionFromDomain('_+,target,[target,target]) +; multfunc:= getFunctionFromDomain('_*,target,[target,target]) +; pat:= [MEMBER(x,v1) and POSN1(x,v1) for x in v2] +; for [e,:c] in u until not z repeat +; z:= coerceInt(objNewWrap(c,S),target) => +; li:= VEC2LIST e +; a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat],one)] +; x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) +; NIL +; z => x +; coercionFailure() + +(DEFUN |coerceDmp2| (|u| |source| |target|) + (PROG (|v2| T$ |v1| S |one| |plusfunc| |multfunc| |pat| |e| |c| |z| |li| + |a| |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |v1| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (SPADLET |x| (|domainZero| |target|)) + (SPADLET |one| (|domainOne| T$)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |pat| + (PROG (#0=#:G166392) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166397 |v2| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS (AND (|member| |x| |v1|) (POSN1 |x| |v1|)) #0#)))))))) + (DO ((#2=#:G166408 |u| (CDR #2#)) + (#3=#:G166357 NIL) + (#4=#:G166409 NIL (NULL |z|))) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #3#)) (SPADLET |c| (CDR #3#)) #3#) + NIL) + #4#) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |z| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (SPADLET |li| (VEC2LIST |e|)) + (SPADLET |a| + (CONS + (CONS + (LIST2VEC + (PROG (#5=#:G166421) + (SPADLET #5# NIL) + (RETURN + (DO ((#6=#:G166426 |pat| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) + (NREVERSE0 #5#)) + (SEQ + (EXIT + (SETQ #5# + (CONS + (COND (|x| (ELT |li| |x|)) ((QUOTE T) 0)) + #5#)))))))) + |one|) + NIL)) + (SPADLET |x| + (SPADCALL |x| + (SPADCALL (|objValUnwrap| |z|) |a| |multfunc|) + |plusfunc|))) + ((QUOTE T) NIL))))) + (COND (|z| |x|) ((QUOTE T) (|coercionFailure|)))))))) + +;Dmp2Expr(u,source is [dmp,vars,S], target is [Expr,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S, target) +; null vars => +; [[., :c]] := u +; not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() +; objValUnwrap(c) +; syms := [objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) for +; var in vars] +; sum := domainZero(target) +; plus := getFunctionFromDomain("+", target, [target, target]) +; mult := getFunctionFromDomain("*", target, [target, target]) +; expn := getFunctionFromDomain("**", target, [target, $Integer]) +; for [e, :c] in u repeat +; not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() +; c := objValUnwrap(c) +; term := domainOne(target) +; for i in 0.. for sym in syms repeat +; exp := e.i +; e.i > 0 => term := SPADCALL(term, SPADCALL(sym, e.i, expn), mult) +; sum := SPADCALL(sum, SPADCALL(c, term, mult), plus) +; sum + +(DEFUN |Dmp2Expr| (|u| |source| |target|) + (PROG (|Expr| T$ |dmp| |vars| S |syms| |plus| |mult| |expn| |e| |c| + |exp| |term| |sum|) + (RETURN + (SEQ + (PROGN + (SPADLET |Expr| (CAR |target|)) + (SPADLET T$ (CADR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |vars| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((NULL |vars|) + (SPADLET |c| (CDAR |u|)) + (COND + ((NULL (SPADLET |c| (|coerceInt| (|objNewWrap| |c| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |c|)))) + ((QUOTE T) + (SPADLET |syms| + (PROG (#0=#:G166499) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166504 |vars| (CDR #1#)) (|var| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |var| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (|objValUnwrap| + (|coerceInt| (|objNewWrap| |var| |$Symbol|) |target|)) + #0#)))))))) + (SPADLET |sum| (|domainZero| |target|)) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |mult| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |expn| + (|getFunctionFromDomain| + (QUOTE **) + |target| + (CONS |target| (CONS |$Integer| NIL)))) + (DO ((#2=#:G166516 |u| (CDR #2#)) (#3=#:G166457 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #3#)) (SPADLET |c| (CDR #3#)) #3#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (SPADLET |c| (|coerceInt| (|objNewWrap| |c| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |c| (|objValUnwrap| |c|)) + (SPADLET |term| (|domainOne| |target|)) + (DO ((|i| 0 (QSADD1 |i|)) + (#4=#:G166529 |syms| (CDR #4#)) + (|sym| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |sym| (CAR #4#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |exp| (ELT |e| |i|)) + (COND + ((> (ELT |e| |i|) 0) + (SPADLET |term| + (SPADCALL |term| + (SPADCALL |sym| (ELT |e| |i|) |expn|) |mult|)))))))) + (SPADLET |sum| + (SPADCALL |sum| (SPADCALL |c| |term| |mult|) |plus|))))))) + |sum|))))))) + +;Dmp2Mp(u, source is [dmp, x, S], target is [mp, y, T]) == +; source' := [dmp,y,T] +; u = '_$fromCoerceable_$ => +; x = y => canCoerce(S,T) +; canCoerce(source',target) +; null u => domainZero(target) -- 0 dmp is = nil +; x ^= y => +; (u' := coerceInt(objNewWrap(u,source),source')) or coercionFailure() +; (u' := coerceInt(u',target)) or coercionFailure() +; objValUnwrap(u') +; -- slight optimization for case #u = 1, x=y , #x =1 and S=T +; -- I know it's pathological, but it may avoid an instantiation +; (x=y) and (1 = #u) and (1 = #x) and (S = T) => +; [1,1,[(CAAR u).0,0,:CDAR u]] +; (u' := coerceDmpCoeffs(u,S,T)) = 'failed => +; coercionFailure() +; plusfunc := getFunctionFromDomain("+",target,[target,target]) +; u'' := genMpFromDmpTerm(u'.0, 0) +; for i in 1..(#u' - 1) repeat +; u'' := SPADCALL(u'',genMpFromDmpTerm(u'.i, 0),plusfunc) +; u'' + +(DEFUN |Dmp2Mp| (|u| |source| |target|) + (PROG (|mp| |y| T$ |dmp| |x| S |source'| |u'| |plusfunc| |u''|) + (RETURN + (SEQ + (PROGN + (SPADLET |mp| (CAR |target|)) + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (SPADLET |source'| (CONS |dmp| (CONS |y| (CONS T$ NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((BOOT-EQUAL |x| |y|) (|canCoerce| S T$)) + ((QUOTE T) (|canCoerce| |source'| |target|)))) + ((NULL |u|) (|domainZero| |target|)) + ((NEQUAL |x| |y|) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) |source'|)) + (|coercionFailure|)) + (OR + (SPADLET |u'| (|coerceInt| |u'| |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((AND (BOOT-EQUAL |x| |y|) + (EQL 1 (|#| |u|)) + (EQL 1 (|#| |x|)) + (BOOT-EQUAL S T$)) + (CONS 1 + (CONS 1 + (CONS + (CONS (ELT (CAAR |u|) 0) (CONS 0 (CDAR |u|))) + NIL)))) + ((BOOT-EQUAL + (SPADLET |u'| (|coerceDmpCoeffs| |u| S T$)) + (QUOTE |failed|)) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |u''| (|genMpFromDmpTerm| (ELT |u'| 0) 0)) + (DO ((#0=#:G166590 (SPADDIFFERENCE (|#| |u'|) 1)) (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| #0#) NIL) + (SEQ + (EXIT + (SPADLET |u''| + (SPADCALL |u''| + (|genMpFromDmpTerm| (ELT |u'| |i|) 0) |plusfunc|))))) + |u''|))))))) + +;coerceDmpCoeffs(u,S,T) == +; -- u is a dmp, S is domain of coeffs, T is domain to coerce coeffs to +; S = T => u +; u' := nil +; bad := nil +; for [e,:c] in u repeat +; bad => nil +; null (c' := coerceInt(objNewWrap(c,S),T)) => return (bad := true) +; u' := [[e,:objValUnwrap(c')],:u'] +; bad => 'failed +; nreverse u' + +(DEFUN |coerceDmpCoeffs| (|u| S T$) + (PROG (|e| |c| |c'| |bad| |u'|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL S T$) |u|) + ((QUOTE T) + (SPADLET |u'| NIL) + (SPADLET |bad| NIL) + (DO ((#0=#:G166620 |u| (CDR #0#)) (#1=#:G166611 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + (|bad| NIL) + ((NULL (SPADLET |c'| (|coerceInt| (|objNewWrap| |c| S) T$))) + (RETURN (SPADLET |bad| (QUOTE T)))) + ((QUOTE T) + (SPADLET |u'| (CONS (CONS |e| (|objValUnwrap| |c'|)) |u'|))))))) + (COND + (|bad| (QUOTE |failed|)) + ((QUOTE T) (NREVERSE |u'|))))))))) + +;sortAndReorderDmpExponents(u,vl) == +; vl' := reverse MSORT vl +; n := (-1) + #vl +; pos := LIST2VEC LZeros (n+1) +; for i in 0..n repeat pos.i := position(vl.i,vl') +; u' := nil +; for [e,:c] in u repeat +; e' := LIST2VEC LZeros (n+1) +; for i in 0..n repeat e'.(pos.i) := e.i +; u' := [[e',:c],:u'] +; reverse u' + +(DEFUN |sortAndReorderDmpExponents| (|u| |vl|) + (PROG (|vl'| |n| |pos| |e| |c| |e'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |vl'| (REVERSE (MSORT |vl|))) + (SPADLET |n| (PLUS (SPADDIFFERENCE 1) (|#| |vl|))) + (SPADLET |pos| (LIST2VEC (|LZeros| (PLUS |n| 1)))) + (DO ((|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) NIL) + (SEQ (EXIT (SETELT |pos| |i| (|position| (ELT |vl| |i|) |vl'|))))) + (SPADLET |u'| NIL) + (DO ((#0=#:G166656 |u| (CDR #0#)) (#1=#:G166638 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |e'| (LIST2VEC (|LZeros| (PLUS |n| 1)))) + (DO ((|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) NIL) + (SEQ (EXIT (SETELT |e'| (ELT |pos| |i|) (ELT |e| |i|))))) + (SPADLET |u'| (CONS (CONS |e'| |c|) |u'|)))))) + (REVERSE |u'|)))))) + +;domain2NDmp(u, source, target is [., y, T]) == +; target' := ['DistributedMultivariatePolynomial,y,T] +; u = '_$fromCoerceable_$ => canCoerce(source,target') +; (u' := coerceInt(objNewWrap(u,source),target')) => +; (u'' := coerceInt(u',target)) => +; objValUnwrap(u'') +; coercionFailure() +; coercionFailure() + +(DEFUN |domain2NDmp| (|u| |source| |target|) + (PROG (|y| T$ |target'| |u'| |u''|) + (RETURN + (PROGN + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |target'| + (CONS + (QUOTE |DistributedMultivariatePolynomial|) + (CONS |y| (CONS T$ NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|canCoerce| |source| |target'|)) + ((SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) |target'|)) + (COND + ((SPADLET |u''| (|coerceInt| |u'| |target|)) (|objValUnwrap| |u''|)) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) (|coercionFailure|))))))) + +;Dmp2NDmp(u,source is [dmp,x,S],target is [ndmp,y,T]) == +; -- a null DMP = 0 +; null u => domainZero(target) +; target' := [dmp,y,T] +; u = '_$fromCoerceable_$ => Dmp2Dmp(u,source,target') +; (u' := Dmp2Dmp(u,source,target')) => addDmpLikeTermsAsTarget(u',target) +; coercionFailure() + +(DEFUN |Dmp2NDmp| (|u| |source| |target|) + (PROG (|ndmp| |y| T$ |dmp| |x| S |target'| |u'|) + (RETURN + (PROGN + (SPADLET |ndmp| (CAR |target|)) + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NULL |u|) (|domainZero| |target|)) + ((QUOTE T) + (SPADLET |target'| (CONS |dmp| (CONS |y| (CONS T$ NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|Dmp2Dmp| |u| |source| |target'|)) + ((SPADLET |u'| (|Dmp2Dmp| |u| |source| |target'|)) + (|addDmpLikeTermsAsTarget| |u'| |target|)) + ((QUOTE T) (|coercionFailure|))))))))) + +;addDmpLikeTermsAsTarget(u,target) == +; u' := domainZero(target) +; func := getFunctionFromDomain("+",target,[target,target]) +; for t in u repeat u' := SPADCALL(u',[t],func) +; u' + +(DEFUN |addDmpLikeTermsAsTarget| (|u| |target|) + (PROG (|func| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |u'| (|domainZero| |target|)) + (SPADLET |func| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (DO ((#0=#:G166739 |u| (CDR #0#)) (|t| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |t| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (SPADLET |u'| (SPADCALL |u'| (CONS |t| NIL) |func|))))) + |u'|))))) + +;-- rewrite ? +;Dmp2P(u, source is [dmp,vl, S], target is [.,T]) == +; -- a null DMP = 0 +; null u => domainZero(target) +; u = '_$fromCoerceable_$ => +; t := canCoerce(S,T) +; null t => canCoerce(S,target) +; t +; S is ['Polynomial,.] => +; mp := coerceInt(objNewWrap(u,source),['MultivariatePolynomial,vl,S]) +; or coercionFailure() +; p := coerceInt(mp,target) or coercionFailure() +; objValUnwrap p +; -- slight optimization for case #u = 1, #vl =1 and S=T +; -- I know it's pathological, but it may avoid an instantiation +; (1 = #u) and (1 = #vl) and (S = T) => +; (lexp:= (CAAR u).0) = 0 => [1,:CDAR u] +; [1,vl.0,[lexp,0,:CDAR u]] +; vl' := reverse MSORT vl +; source' := [dmp,vl',S] +; target' := ['MultivariatePolynomial,vl',S] +; u' := sortAndReorderDmpExponents(u,vl) +; u' := coerceInt(objNewWrap(u',source'),target') +; if u' then +; u' := translateMpVars2PVars (objValUnwrap(u'),vl') +; u' := coerceInt(objNewWrap(u',['Polynomial,S]),target) +; u' => objValUnwrap(u') +; -- get drastic. create monomials +; source' := [dmp,vl,T] +; u' := domainZero(target) +; oneT := domainOne(T) +; plusfunc := getFunctionFromDomain("+",target,[target,target]) +; multfunc := getFunctionFromDomain("*",target,[target,target]) +; for [e,:c] in u repeat +; (c' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; (e' := coerceInt(objNewWrap([[e,:oneT]],source'),target)) or +; coercionFailure() +; t := SPADCALL(objValUnwrap(e'),objValUnwrap(c'),multfunc) +; u' := SPADCALL(u',t,plusfunc) +; coercionFailure() + +(DEFUN |Dmp2P| (|u| |source| |target|) + (PROG (T$ |dmp| |vl| S |ISTMP#1| |mp| |p| |lexp| |vl'| |target'| |source'| + |oneT| |plusfunc| |multfunc| |e| |c| |c'| |e'| |t| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |vl| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NULL |u|) (|domainZero| |target|)) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (SPADLET |t| (|canCoerce| S T$)) + (COND ((NULL |t|) (|canCoerce| S |target|)) ((QUOTE T) |t|))) + ((AND (PAIRP S) + (EQ (QCAR S) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR S)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |mp| + (OR + (|coerceInt| + (|objNewWrap| |u| |source|) + (CONS (QUOTE |MultivariatePolynomial|) (CONS |vl| (CONS S NIL)))) + (|coercionFailure|))) + (SPADLET |p| (OR (|coerceInt| |mp| |target|) (|coercionFailure|))) + (|objValUnwrap| |p|)) + ((AND (EQL 1 (|#| |u|)) (EQL 1 (|#| |vl|)) (BOOT-EQUAL S T$)) + (COND + ((EQL (SPADLET |lexp| (ELT (CAAR |u|) 0)) 0) (CONS 1 (CDAR |u|))) + ((QUOTE T) + (CONS 1 + (CONS (ELT |vl| 0) + (CONS (CONS |lexp| (CONS 0 (CDAR |u|))) NIL)))))) + ((QUOTE T) + (SPADLET |vl'| (REVERSE (MSORT |vl|))) + (SPADLET |source'| (CONS |dmp| (CONS |vl'| (CONS S NIL)))) + (SPADLET |target'| + (CONS (QUOTE |MultivariatePolynomial|) (CONS |vl'| (CONS S NIL)))) + (SPADLET |u'| (|sortAndReorderDmpExponents| |u| |vl|)) + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u'| |source'|) |target'|)) + (COND + (|u'| + (SPADLET |u'| (|translateMpVars2PVars| (|objValUnwrap| |u'|) |vl'|)) + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u'| + (CONS (QUOTE |Polynomial|) (CONS S NIL))) |target|)))) + (COND + (|u'| (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |source'| (CONS |dmp| (CONS |vl| (CONS T$ NIL)))) + (SPADLET |u'| (|domainZero| |target|)) + (SPADLET |oneT| (|domainOne| T$)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (DO ((#0=#:G166802 |u| (CDR #0#)) (#1=#:G166758 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (OR + (SPADLET |c'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (OR + (SPADLET |e'| + (|coerceInt| + (|objNewWrap| + (CONS (CONS |e| |oneT|) NIL) |source'|) |target|)) + (|coercionFailure|)) + (SPADLET |t| + (SPADCALL + (|objValUnwrap| |e'|) + (|objValUnwrap| |c'|) + |multfunc|)) + (SPADLET |u'| (SPADCALL |u'| |t| |plusfunc|)))))) + (|coercionFailure|)))))))))) + +;translateMpVars2PVars (u, vl) == +; u is [ =1, v, :termlist] => +; [ 1, vl.(v-1), +; :[[e,:translateMpVars2PVars(c,vl)] for [e,:c] in termlist]] +; u + +(DEFUN |translateMpVars2PVars| (|u| |vl|) + (PROG (|ISTMP#1| |v| |termlist| |e| |c|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |termlist| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (CONS 1 + (CONS + (ELT |vl| (SPADDIFFERENCE |v| 1)) + (PROG (#0=#:G166857) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166863 |termlist| (CDR #1#)) (#2=#:G166847 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #2#)) + (SPADLET |c| (CDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS (CONS |e| (|translateMpVars2PVars| |c| |vl|)) #0#)))))))))) + ((QUOTE T) |u|)))))) + +;Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) == +; null u => -- this is true if u = 0 +; domainZero(target) +; u = '_$fromCoerceable_$ => +; MEMBER(var,vl) => +; vl' := REMOVE(vl,var) +; null vl' => -- no remaining variables +; canCoerce(S,T) +; null rest vl' => -- one remaining variable +; canCoerce([up,first vl',S],T) +; canCoerce([dmp,vl',S], T) +; canCoerce(source,T) +; -- check constant case +; (null rest u) and (first(u) is [e,:c]) and +; ( and/[(0 = e.i) for i in 0..(-1 + #vl)] ) => +; (x := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(x) +; -- check non-member case +; null MEMBER(var,vl) => +; (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() +; [[0,:objValUnwrap u']] +; vl' := REMOVE(vl,var) +; -- only one variable in DMP case +; null vl' => +; u' := nreverse SORTBY('CAR,[[e.0,:c] for [e,:c] in u]) +; (u' := coerceInt(objNewWrap(u',[up,var,S]),target)) or +; coercionFailure() +; objValUnwrap u' +; S1 := [dmp,vl',S] +; plusfunc:= getFunctionFromDomain('_+,T,[T,T]) +; zero := getConstantFromDomain('(Zero),T) +; x := NIL +; pos:= POSN1(var,vl) +; for [e,:c] in u until not y repeat +; exp:= e.pos +; e1:= removeVectorElt(e,pos) +; y:= coerceInt(objNewWrap([[e1,:c]],S1),T) => +; -- need to be careful about zeros +; p:= ASSQ(exp,x) => +; c' := SPADCALL(CDR p,objValUnwrap(y),plusfunc) +; c' = zero => x := REMALIST(x,exp) +; RPLACD(p,c') +; zero = objValUnwrap(y) => 'iterate +; x := CONS(CONS(exp,objValUnwrap(y)),x) +; y => nreverse SORTBY('CAR,x) +; coercionFailure() + +(DEFUN |Dmp2Up| (|u| |source| |target|) + (PROG (|up| |var| T$ |dmp| |vl| S |ISTMP#1| |vl'| |u'| S1 |plusfunc| |zero| + |pos| |e| |c| |exp| |e1| |y| |p| |c'| |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |up| (CAR |target|)) + (SPADLET |var| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |dmp| (CAR |source|)) + (SPADLET |vl| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NULL |u|) (|domainZero| |target|)) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((|member| |var| |vl|) + (SPADLET |vl'| (|remove| |vl| |var|)) + (COND + ((NULL |vl'|) (|canCoerce| S T$)) + ((NULL (CDR |vl'|)) + (|canCoerce| (CONS |up| (CONS (CAR |vl'|) (CONS S NIL))) T$)) + ((QUOTE T) (|canCoerce| (CONS |dmp| (CONS |vl'| (CONS S NIL))) T$)))) + ((QUOTE T) (|canCoerce| |source| T$)))) + ((AND + (NULL (CDR |u|)) + (PROGN + (SPADLET |ISTMP#1| (CAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PROG (#0=#:G166951) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G166957 NIL (NULL #0#)) + (#2=#:G166958 (PLUS (SPADDIFFERENCE 1) (|#| |vl|))) + (|i| 0 (QSADD1 |i|))) + ((OR #1# (QSGREATERP |i| #2#)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (EQL 0 (ELT |e| |i|)))))))))) + (OR + (SPADLET |x| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |x|)) + ((NULL (|member| |var| |vl|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u'|)) NIL)) + ((QUOTE T) + (SPADLET |vl'| (|remove| |vl| |var|)) + (COND + ((NULL |vl'|) + (SPADLET |u'| + (NREVERSE + (SORTBY + (QUOTE CAR) + (PROG (#3=#:G166968) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166974 |u| (CDR #4#)) (#5=#:G166891 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #5#)) + (SPADLET |c| (CDR #5#)) + #5#) + NIL)) + (NREVERSE0 #3#)) + (SEQ (EXIT (SETQ #3# (CONS (CONS (ELT |e| 0) |c|) #3#)))))))))) + (OR + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u'| (CONS |up| (CONS |var| (CONS S NIL)))) + |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET S1 (CONS |dmp| (CONS |vl'| (CONS S NIL)))) + (SPADLET |plusfunc| + (|getFunctionFromDomain| (QUOTE +) T$ (CONS T$ (CONS T$ NIL)))) + (SPADLET |zero| (|getConstantFromDomain| (QUOTE (|Zero|)) T$)) + (SPADLET |x| NIL) + (SPADLET |pos| (POSN1 |var| |vl|)) + (DO ((#6=#:G166989 |u| (CDR #6#)) + (#7=#:G166899 NIL) + (#8=#:G166990 NIL (NULL |y|))) + ((OR (ATOM #6#) + (PROGN (SETQ #7# (CAR #6#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #7#)) + (SPADLET |c| (CDR #7#)) + #7#) + NIL) + #8#) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |exp| (ELT |e| |pos|)) + (SPADLET |e1| (|removeVectorElt| |e| |pos|)) + (COND + ((SPADLET |y| (|coerceInt| (|objNewWrap| (CONS (CONS |e1| |c|) NIL) S1) T$)) + (COND + ((SPADLET |p| (ASSQ |exp| |x|)) + (SPADLET |c'| + (SPADCALL (CDR |p|) (|objValUnwrap| |y|) |plusfunc|)) + (COND + ((BOOT-EQUAL |c'| |zero|) + (SPADLET |x| (REMALIST |x| |exp|))) + ((QUOTE T) + (RPLACD |p| |c'|)))) + ((BOOT-EQUAL |zero| (|objValUnwrap| |y|)) (QUOTE |iterate|)) + ((QUOTE T) + (SPADLET |x| + (CONS (CONS |exp| (|objValUnwrap| |y|)) |x|)))))))))) + (COND + (|y| (NREVERSE (SORTBY (QUOTE CAR) |x|))) + ((QUOTE T) (|coercionFailure|)))))))))))) + +;removeVectorElt(v,pos) == +; -- removes the pos'th element from vector v +; LIST2VEC [x for x in VEC2LIST v for y in 0.. | not (y=pos)] + +(DEFUN |removeVectorElt| (|v| |pos|) + (PROG NIL + (RETURN + (SEQ + (LIST2VEC + (PROG (#0=#:G167040) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167047 (VEC2LIST |v|) (CDR #1#)) + (|x| NIL) + (|y| 0 (QSADD1 |y|))) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((NULL (BOOT-EQUAL |y| |pos|)) + (SETQ #0# (CONS |x| #0#)))))))))))))) + +;removeListElt(l,pos) == +; pos = 0 => CDR l +; [CAR l, :removeListElt(CDR l,pos-1)] + +(DEFUN |removeListElt| (|l| |pos|) + (COND + ((EQL |pos| 0) (CDR |l|)) + ((QUOTE T) + (CONS (CAR |l|) (|removeListElt| (CDR |l|) (SPADDIFFERENCE |pos| 1)))))) + +;NDmp2domain(u,source is [ndmp,x,S],target) == +; -- a null NDMP = 0 +; null u => domainZero(target) +; dmp := 'DistributedMultivariatePolynomial +; source' := [dmp,x,S] +; u = '_$fromCoerceable_$ => canCoerce(source',target) +; u' := addDmpLikeTermsAsTarget(u,source') +; (u'' := coerceInt(objNewWrap(u',source'),target)) => +; objValUnwrap(u'') +; coercionFailure() + +(DEFUN |NDmp2domain| (|u| |source| |target|) + (PROG (|ndmp| |x| S |dmp| |source'| |u'| |u''|) + (RETURN + (PROGN + (SPADLET |ndmp| (CAR |source|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NULL |u|) (|domainZero| |target|)) + ((QUOTE T) + (SPADLET |dmp| (QUOTE |DistributedMultivariatePolynomial|)) + (SPADLET |source'| (CONS |dmp| (CONS |x| (CONS S NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|canCoerce| |source'| |target|)) + ((QUOTE T) + (SPADLET |u'| (|addDmpLikeTermsAsTarget| |u| |source'|)) + (COND + ((SPADLET |u''| (|coerceInt| (|objNewWrap| |u'| |source'|) |target|)) + (|objValUnwrap| |u''|)) + ((QUOTE T) + (|coercionFailure|))))))))))) + +;NDmp2NDmp(u,source is [ndmp,x,S],target is [.,y,T]) == +; -- a null NDMP = 0 +; null u => domainZero(target) +; dmp := 'DistributedMultivariatePolynomial +; source' := [dmp,x,S] +; target' := [dmp,y,T] +; u = '_$fromCoerceable_$ => canCoerce(source',target') +; u' := addDmpLikeTermsAsTarget(u,source') +; (u'' := coerceInt(objNewWrap(u',source'),target')) => +; addDmpLikeTermsAsTarget(objValUnwrap(u''),target) +; coercionFailure() + +(DEFUN |NDmp2NDmp| (|u| |source| |target|) + (PROG (|y| T$ |ndmp| |x| S |dmp| |source'| |target'| |u'| |u''|) + (RETURN + (PROGN + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |ndmp| (CAR |source|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((NULL |u|) (|domainZero| |target|)) + ((QUOTE T) + (SPADLET |dmp| (QUOTE |DistributedMultivariatePolynomial|)) + (SPADLET |source'| (CONS |dmp| (CONS |x| (CONS S NIL)))) + (SPADLET |target'| (CONS |dmp| (CONS |y| (CONS T$ NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|canCoerce| |source'| |target'|)) + ((QUOTE T) + (SPADLET |u'| (|addDmpLikeTermsAsTarget| |u| |source'|)) + (COND + ((SPADLET |u''| (|coerceInt| (|objNewWrap| |u'| |source'|) |target'|)) + (|addDmpLikeTermsAsTarget| (|objValUnwrap| |u''|) |target|)) + ((QUOTE T) (|coercionFailure|))))))))))) + +;--% Expression +;Expr2Complex(u,source is [.,S], target is [.,T]) == +; u = '_$fromCoerceable_$ => nil -- can't tell, in general +; not member(S, [$Integer, $Float, $DoubleFloat]) => coercionFailure() +; not member(T, [$Float, $DoubleFloat]) => coercionFailure() +; complexNumeric := getFunctionFromDomain("complexNumeric", ['Numeric, S], [source]) +; -- the following might fail +; cf := SPADCALL(u,complexNumeric) -- returns a Float +; T = $DoubleFloat => +; null (z := coerceInt(objNewWrap(cf, ['Complex, $Float]), ['Complex, $DoubleFloat])) => +; coercionFailure() +; objValUnwrap z +; cf + +(DEFUN |Expr2Complex| (|u| |source| |target|) + (PROG (T$ S |complexNumeric| |cf| |z|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((NULL + (|member| S + (CONS |$Integer| (CONS |$Float| (CONS |$DoubleFloat| NIL))))) + (|coercionFailure|)) + ((NULL (|member| T$ (CONS |$Float| (CONS |$DoubleFloat| NIL)))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |complexNumeric| + (|getFunctionFromDomain| + (QUOTE |complexNumeric|) + (CONS (QUOTE |Numeric|) (CONS S NIL)) (CONS |source| NIL))) + (SPADLET |cf| (SPADCALL |u| |complexNumeric|)) + (COND + ((BOOT-EQUAL T$ |$DoubleFloat|) + (COND + ((NULL + (SPADLET |z| + (|coerceInt| + (|objNewWrap| |cf| (CONS (QUOTE |Complex|) (CONS |$Float| NIL))) + (CONS (QUOTE |Complex|) (CONS |$DoubleFloat| NIL))))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |z|)))) + ((QUOTE T) |cf|)))))))) + +;Expr2Dmp(u,source is [Expr,S], target is [dmp,v2,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source, T) +; null v2 => +; not (z := coerceInt(objNewWrap(u, source), T)) => coercionFailure() +; [[LIST2VEC NIL, :objValUnwrap z]] +; obj := objNewWrap(u, source) +; univ := coerceInt(obj, ['UnivariatePolynomial, first v2, T]) +; not univ => +; T = source => coercionFailure() +; not (z := coerceInt(obj, [dmp, v2, source])) => +; coercionFailure() +; z := objValUnwrap z +; for term in z repeat +; [., :c] := term +; not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() +; RPLACD(term, objValUnwrap c) +; z +; univ := objValUnwrap univ +; -- only one variable +; null rest v2 => +; for term in univ repeat +; RPLACA(term, VECTOR CAR term) +; univ +; -- more than one variable +; summands := nil +; for [e,:c] in univ repeat +; summands := Expr2Dmp1(summands, +; LIST2VEC [e, :[0 for v in rest v2]], c, T, 1, rest v2, T) +; plus := getFunctionFromDomain("+", target, [target, target]) +; sum := domainZero target +; for summand in summands repeat +; sum := SPADCALL([summand], sum, plus) +; sum + +(DEFUN |Expr2Dmp| (|u| |source| |target|) + (PROG (|dmp| |v2| T$ |Expr| S |obj| |z| |univ| |e| |c| + |summands| |plus| |sum|) + (RETURN + (SEQ + (PROGN + (SPADLET |dmp| (CAR |target|)) + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |Expr| (CAR |source|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((NULL |v2|) + (COND + ((NULL (SPADLET |z| (|coerceInt| (|objNewWrap| |u| |source|) T$))) + (|coercionFailure|)) + ((QUOTE T) (CONS (CONS (LIST2VEC NIL) (|objValUnwrap| |z|)) NIL)))) + ((QUOTE T) + (SPADLET |obj| (|objNewWrap| |u| |source|)) + (SPADLET |univ| + (|coerceInt| |obj| + (CONS + (QUOTE |UnivariatePolynomial|) + (CONS (CAR |v2|) (CONS T$ NIL))))) + (COND + ((NULL |univ|) + (COND + ((BOOT-EQUAL T$ |source|) (|coercionFailure|)) + ((NULL + (SPADLET |z| + (|coerceInt| |obj| (CONS |dmp| (CONS |v2| (CONS |source| NIL)))))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |z| (|objValUnwrap| |z|)) + (DO ((#0=#:G167192 |z| (CDR #0#)) (|term| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |term| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |c| (CDR |term|)) + (COND + ((NULL + (SPADLET |c| (|coerceInt| (|objNewWrap| |c| |source|) T$))) + (|coercionFailure|)) + ((QUOTE T) (RPLACD |term| (|objValUnwrap| |c|)))))))) + |z|))) + ((QUOTE T) + (SPADLET |univ| (|objValUnwrap| |univ|)) + (COND + ((NULL (CDR |v2|)) + (DO ((#1=#:G167201 |univ| (CDR #1#)) (|term| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |term| (CAR #1#)) NIL)) NIL) + (SEQ (EXIT (RPLACA |term| (VECTOR (CAR |term|)))))) + |univ|) + ((QUOTE T) + (SPADLET |summands| NIL) + (DO ((#2=#:G167211 |univ| (CDR #2#)) (#3=#:G167150 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #3#)) + (SPADLET |c| (CDR #3#)) + #3#) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |summands| + (|Expr2Dmp1| |summands| + (LIST2VEC + (CONS |e| + (PROG (#4=#:G167222) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G167227 (CDR |v2|) (CDR #5#)) (|v| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |v| (CAR #5#)) NIL)) + (NREVERSE0 #4#)) + (SEQ (EXIT (SETQ #4# (CONS 0 #4#))))))))) + |c| T$ 1 (CDR |v2|) T$))))) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |sum| (|domainZero| |target|)) + (DO ((#6=#:G167236 |summands| (CDR #6#)) (|summand| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |summand| (CAR #6#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |sum| (SPADCALL (CONS |summand| NIL) |sum| |plus|))))) + |sum|))))))))))) + +;Expr2Dmp1(summands, vec, c, source, index, varList, T) == +; if null varList then +; if not (source = T) then +; not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() +; c := objValUnwrap c +; summands := [[vec, :c], :summands] +; else +; univ := coerceInt(objNewWrap(c, source), +; ['UnivariatePolynomial, first varList, T]) +; univ := objValUnwrap univ +; for [e,:c] in univ repeat +; vec := COPY_-SEQ vec +; vec.index := e +; summands := Expr2Dmp1(summands, vec, c, T, index+1, rest varList, T) +; summands + +(DEFUN |Expr2Dmp1| (|summands| |vec| |c| |source| |index| |varList| T$) + (PROG (|univ| |e|) + (RETURN + (SEQ + (PROGN + (COND + ((NULL |varList|) + (COND + ((NULL (BOOT-EQUAL |source| T$)) + (COND + ((NULL (SPADLET |c| (|coerceInt| (|objNewWrap| |c| |source|) T$))) + (|coercionFailure|)) + ((QUOTE T) (SPADLET |c| (|objValUnwrap| |c|)))))) + (SPADLET |summands| (CONS (CONS |vec| |c|) |summands|))) + ((QUOTE T) + (SPADLET |univ| + (|coerceInt| + (|objNewWrap| |c| |source|) + (CONS + (QUOTE |UnivariatePolynomial|) + (CONS (CAR |varList|) (CONS T$ NIL))))) + (SPADLET |univ| (|objValUnwrap| |univ|)) + (DO ((#0=#:G167282 |univ| (CDR #0#)) (#1=#:G167269 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |vec| (COPY-SEQ |vec|)) + (SETELT |vec| |index| |e|) + (SPADLET |summands| + (|Expr2Dmp1| |summands| |vec| |c| + T$ (PLUS |index| 1) (CDR |varList|) T$)))))))) + |summands|))))) + +;Expr2Mp(u,source is [Expr,S], target is [.,v2,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source, T) +; dmp := ['DistributedMultivariatePolynomial,v2,T] +; d := Expr2Dmp(u,source, dmp) +; not (m := coerceInt(objNewWrap(d, dmp), target)) => coercionFailure() +; objValUnwrap m + +(DEFUN |Expr2Mp| (|u| |source| |target|) + (PROG (|v2| T$ |Expr| S |dmp| |d| |m|) + (RETURN + (PROGN + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |Expr| (CAR |source|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((QUOTE T) + (SPADLET |dmp| + (CONS + (QUOTE |DistributedMultivariatePolynomial|) + (CONS |v2| (CONS T$ NIL)))) + (SPADLET |d| (|Expr2Dmp| |u| |source| |dmp|)) + (COND + ((NULL (SPADLET |m| (|coerceInt| (|objNewWrap| |d| |dmp|) |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |m|))))))))) + +;Expr2Up(u,source is [Expr,S], target is [.,var,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source, T) +; kernelFunc := getFunctionFromDomain("kernels", source, [source]) +; kernelDom := ['Kernel, source] +; nameFunc := getFunctionFromDomain("name", kernelDom, [kernelDom]) +; kernels := SPADCALL(u,kernelFunc) +; v1 := [SPADCALL(kernel, nameFunc) for kernel in kernels] +; not member(var, v1) => coercionFailure() +; -- variable is a kernel +; varKernel := kernels.(POSN1(var, v1)) +; univFunc := getFunctionFromDomain("univariate", source, [source, kernelDom]) +; sup := ['SparseUnivariatePolynomial, source] +; fracUniv := SPADCALL(u, varKernel, univFunc) +; denom := CDR fracUniv +; not equalOne(denom, sup) => coercionFailure() +; numer := CAR fracUniv +; uniType := ['UnivariatePolynomial, var, source] +; (z := coerceInt(objNewWrap(numer, uniType), target)) => objValUnwrap z +; coercionFailure() + +(DEFUN |Expr2Up| (|u| |source| |target|) + (PROG (|var| T$ |Expr| S |kernelFunc| |kernelDom| |nameFunc| |kernels| |v1| + |varKernel| |univFunc| |sup| |fracUniv| |denom| |numer| |uniType| |z|) + (RETURN + (SEQ + (PROGN + (SPADLET |var| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |Expr| (CAR |source|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((QUOTE T) + (SPADLET |kernelFunc| + (|getFunctionFromDomain| + (QUOTE |kernels|) + |source| + (CONS |source| NIL))) + (SPADLET |kernelDom| (CONS (QUOTE |Kernel|) (CONS |source| NIL))) + (SPADLET |nameFunc| + (|getFunctionFromDomain| + (QUOTE |name|) + |kernelDom| + (CONS |kernelDom| NIL))) + (SPADLET |kernels| (SPADCALL |u| |kernelFunc|)) + (SPADLET |v1| + (PROG (#0=#:G167357) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167362 |kernels| (CDR #1#)) (|kernel| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |kernel| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (SPADCALL |kernel| |nameFunc|) #0#)))))))) + (COND + ((NULL (|member| |var| |v1|)) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |varKernel| (ELT |kernels| (POSN1 |var| |v1|))) + (SPADLET |univFunc| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| + (CONS |source| (CONS |kernelDom| NIL)))) + (SPADLET |sup| + (CONS (QUOTE |SparseUnivariatePolynomial|) (CONS |source| NIL))) + (SPADLET |fracUniv| (SPADCALL |u| |varKernel| |univFunc|)) + (SPADLET |denom| (CDR |fracUniv|)) + (COND + ((NULL (|equalOne| |denom| |sup|)) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |numer| (CAR |fracUniv|)) + (SPADLET |uniType| + (CONS + (QUOTE |UnivariatePolynomial|) + (CONS |var| (CONS |source| NIL)))) + (COND + ((SPADLET |z| + (|coerceInt| (|objNewWrap| |numer| |uniType|) |target|)) + (|objValUnwrap| |z|)) + ((QUOTE T) (|coercionFailure|)))))))))))))) + +;--% Kernels over Expr +;Ker2Ker(u,source is [.,S], target is [.,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S, T) +; not (m := coerceInt(objNewWrap(u, source), S)) => coercionFailure() +; u' := objValUnwrap m +; not (m' := coerceInt(objNewWrap(u', S), T)) => coercionFailure() +; u'' := objValUnwrap m' +; not (m'' := coerceInt(objNewWrap(u'', T), target)) => coercionFailure() +; objValUnwrap m'' + +(DEFUN |Ker2Ker| (|u| |source| |target|) + (PROG (T$ S |m| |u'| |m'| |u''| |m''|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((NULL (SPADLET |m| (|coerceInt| (|objNewWrap| |u| |source|) S))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |u'| (|objValUnwrap| |m|)) + (COND + ((NULL (SPADLET |m'| (|coerceInt| (|objNewWrap| |u'| S) T$))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |u''| (|objValUnwrap| |m'|)) + (COND + ((NULL (SPADLET |m''| (|coerceInt| (|objNewWrap| |u''| T$) |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |m''|))))))))))) + +;Ker2Expr(u,source is [.,S], target) == +; u = '_$fromCoerceable_$ => canCoerce(S, target) +; not (m := coerceByFunction(objNewWrap(u, source), S)) => coercionFailure() +; u':= objValUnwrap m +; not (m' := coerceInt(objNewWrap(u', S), target)) => coercionFailure() +; objValUnwrap m' + +(DEFUN |Ker2Expr| (|u| |source| |target|) + (PROG (S |m| |u'| |m'|) + (RETURN + (PROGN + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((NULL (SPADLET |m| (|coerceByFunction| (|objNewWrap| |u| |source|) S))) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |u'| (|objValUnwrap| |m|)) + (COND + ((NULL (SPADLET |m'| (|coerceInt| (|objNewWrap| |u'| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |m'|))))))))) +;--% Factored objects +;Factored2Factored(u,oldmode,newmode) == +; [.,oldargmode,:.]:= oldmode +; [.,newargmode,:.]:= newmode +; u = '_$fromCoerceable_$ => canCoerce(oldargmode,newargmode) +; u' := unwrap u +; unit' := coerceInt(objNewWrap(first u',oldargmode),newargmode) +; null unit' => coercionFailure() +; factors := KDR u' +; factors' := [(coerceFFE(x,oldargmode,newargmode)) for x in factors] +; MEMBER('failed,factors') => coercionFailure() +; [objValUnwrap(unit'),:factors'] + +(DEFUN |Factored2Factored| (|u| |oldmode| |newmode|) + (PROG (|oldargmode| |newargmode| |u'| |unit'| |factors| |factors'|) + (RETURN + (SEQ + (PROGN + (SPADLET |oldargmode| (CADR |oldmode|)) + (SPADLET |newargmode| (CADR |newmode|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|canCoerce| |oldargmode| |newargmode|)) + ((QUOTE T) + (SPADLET |u'| (|unwrap| |u|)) + (SPADLET |unit'| + (|coerceInt| (|objNewWrap| (CAR |u'|) |oldargmode|) |newargmode|)) + (COND + ((NULL |unit'|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |factors| (KDR |u'|)) + (SPADLET |factors'| + (PROG (#0=#:G167438) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167443 |factors| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS (|coerceFFE| |x| |oldargmode| |newargmode|) #0#)))))))) + (COND + ((|member| (QUOTE |failed|) |factors'|) (|coercionFailure|)) + ((QUOTE T) (CONS (|objValUnwrap| |unit'|) |factors'|)))))))))))) + +;coerceFFE(ffe, oldmode, newmode) == +; fac' := coerceInt(objNewWrap(ffe.1,oldmode),newmode) +; null fac' => 'failed +; LIST2VEC [ffe.0,objValUnwrap(fac'),ffe.2] + +(DEFUN |coerceFFE| (|ffe| |oldmode| |newmode|) + (PROG (|fac'|) + (RETURN + (PROGN + (SPADLET |fac'| + (|coerceInt| (|objNewWrap| (ELT |ffe| 1) |oldmode|) |newmode|)) + (COND + ((NULL |fac'|) (QUOTE |failed|)) + ((QUOTE T) + (LIST2VEC + (CONS + (ELT |ffe| 0) + (CONS (|objValUnwrap| |fac'|) (CONS (ELT |ffe| 2) NIL)))))))))) + +;--% Complex +;Complex2underDomain(u,[.,S],target) == +; u = '_$fromCoerceable_$ => nil +; [r,:i] := u +; i=domainZero(S) => +; [r',.,.]:= coerceInt(objNewWrap(r,S),target) or +; coercionFailure() +; r' +; coercionFailure() + +(DEFUN |Complex2underDomain| (|u| #0=#:G167474 |target|) + (PROG (S |r| |i| |LETTMP#1| |r'|) + (RETURN + (PROGN + (SPADLET S (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) + (SPADLET |r| (CAR |u|)) + (SPADLET |i| (CDR |u|)) + (COND + ((BOOT-EQUAL |i| (|domainZero| S)) + (SPADLET |LETTMP#1| + (OR (|coerceInt| (|objNewWrap| |r| S) |target|) (|coercionFailure|))) + (SPADLET |r'| (CAR |LETTMP#1|)) + |r'|) + ((QUOTE T) (|coercionFailure|))))))))) + +;Complex2FR(u,S is [.,R],target is [.,T]) == +; u = '_$fromCoerceable_$ => +; S ^= T => nil +; R = $Integer => true +; nil +; S ^= T => coercionFailure() +; package := +; R = $Integer => ['GaussianFactorizationPackage] +; coercionFailure() +; factor := getFunctionFromDomain('factor,package,[S]) +; SPADCALL(u,factor) + +(DEFUN |Complex2FR| (|u| S |target|) + (PROG (T$ R |package| |factor|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET R (CADR S)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((NEQUAL S T$) NIL) + ((BOOT-EQUAL R |$Integer|) (QUOTE T)) + ((QUOTE T) NIL))) + ((NEQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |package| + (COND + ((BOOT-EQUAL R |$Integer|) + (CONS (QUOTE |GaussianFactorizationPackage|) NIL)) + ((QUOTE T) (|coercionFailure|)))) + (SPADLET |factor| + (|getFunctionFromDomain| + (QUOTE |factor|) + |package| + (CONS S NIL))) + (SPADCALL |u| |factor|))))))) + +;Complex2Expr(u, source is [.,S], target is [., T]) == +; u = '_$fromCoerceable_$ => +; T is ['Complex, T1] and canCoerceFrom(S, T1) or coercionFailure() +; E := defaultTargetFE source +; negOne := coerceInt(objNewWrap(-1, $Integer), E) +; null negOne => coercionFailure() +; sqrtFun := getFunctionFromDomain('sqrt, E, [E]) +; i := SPADCALL(objValUnwrap negOne, sqrtFun) +; realFun := getFunctionFromDomain('real, source, [source]) +; imagFun := getFunctionFromDomain('imag, source, [source]) +; real := SPADCALL(u, realFun) +; imag := SPADCALL(u, imagFun) +; realExp := coerceInt(objNewWrap(real, S), E) +; null realExp => coercionFailure() +; imagExp := coerceInt(objNewWrap(imag, S), E) +; null imagExp => coercionFailure() +; timesFun := getFunctionFromDomain('_*, E, [E, E]) +; plusFun := getFunctionFromDomain('_+, E, [E, E]) +; newVal := SPADCALL(objValUnwrap(realExp), +; SPADCALL(i, objValUnwrap imagExp, timesFun), plusFun) +; newObj := objNewWrap(newVal, E) +; finalObj := coerceInt(newObj, target) +; finalObj => objValUnwrap finalObj +; coercionFailure() + +(DEFUN |Complex2Expr| (|u| |source| |target|) + (PROG (T$ S |ISTMP#1| T1 E |negOne| |sqrtFun| |i| |realFun| |imagFun| |real| + |imag| |realExp| |imagExp| |timesFun| |plusFun| |newVal| + |newObj| |finalObj|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR + (AND (PAIRP T$) + (EQ (QCAR T$) (QUOTE |Complex|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR T$)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET T1 (QCAR |ISTMP#1|)) (QUOTE T)))) + (|canCoerceFrom| S T1)) + (|coercionFailure|))) + ((QUOTE T) + (SPADLET E (|defaultTargetFE| |source|)) + (SPADLET |negOne| + (|coerceInt| (|objNewWrap| (SPADDIFFERENCE 1) |$Integer|) E)) + (COND + ((NULL |negOne|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |sqrtFun| + (|getFunctionFromDomain| (QUOTE |sqrt|) E (CONS E NIL))) + (SPADLET |i| (SPADCALL (|objValUnwrap| |negOne|) |sqrtFun|)) + (SPADLET |realFun| + (|getFunctionFromDomain| (QUOTE |real|) |source| (CONS |source| NIL))) + (SPADLET |imagFun| + (|getFunctionFromDomain| (QUOTE |imag|) |source| (CONS |source| NIL))) + (SPADLET |real| (SPADCALL |u| |realFun|)) + (SPADLET |imag| (SPADCALL |u| |imagFun|)) + (SPADLET |realExp| (|coerceInt| (|objNewWrap| |real| S) E)) + (COND + ((NULL |realExp|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |imagExp| (|coerceInt| (|objNewWrap| |imag| S) E)) + (COND + ((NULL |imagExp|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |timesFun| + (|getFunctionFromDomain| (QUOTE *) E (CONS E (CONS E NIL)))) + (SPADLET |plusFun| + (|getFunctionFromDomain| (QUOTE +) E (CONS E (CONS E NIL)))) + (SPADLET |newVal| + (SPADCALL + (|objValUnwrap| |realExp|) + (SPADCALL |i| (|objValUnwrap| |imagExp|) |timesFun|) |plusFun|)) + (SPADLET |newObj| (|objNewWrap| |newVal| E)) + (SPADLET |finalObj| (|coerceInt| |newObj| |target|)) + (COND + (|finalObj| (|objValUnwrap| |finalObj|)) + ((QUOTE T) (|coercionFailure|))))))))))))))) + +;--% Integer +;I2EI(n,source,target) == +; n = '_$fromCoerceable_$ => nil +; if not ODDP(n) then n else coercionFailure() + +(DEFUN I2EI (|n| |source| |target|) + (COND + ((BOOT-EQUAL |n| (QUOTE |$fromCoerceable$|)) NIL) + ((NULL (ODDP |n|)) |n|) + ((QUOTE T) (|coercionFailure|)))) + +;I2OI(n,source,target) == +; n = '_$fromCoerceable_$ => nil +; if ODDP(n) then n else coercionFailure() + +(DEFUN I2OI (|n| |source| |target|) + (COND + ((BOOT-EQUAL |n| (QUOTE |$fromCoerceable$|)) NIL) + ((ODDP |n|) |n|) + ((QUOTE T) (|coercionFailure|)))) + +;I2PI(n,source,target) == +; n = '_$fromCoerceable_$ => nil +; if n > 0 then n else coercionFailure() + +(DEFUN I2PI (|n| |source| |target|) + (COND + ((BOOT-EQUAL |n| (QUOTE |$fromCoerceable$|)) NIL) + ((> |n| 0) |n|) + ((QUOTE T) (|coercionFailure|)))) + +;I2NNI(n,source,target) == +; n = '_$fromCoerceable_$ => nil +; if n >= 0 then n else coercionFailure() + +(DEFUN I2NNI (|n| |source| |target|) + (COND + ((BOOT-EQUAL |n| (QUOTE |$fromCoerceable$|)) NIL) + ((>= |n| 0) |n|) + ((QUOTE T) (|coercionFailure|)))) + +;--% List +;L2Tuple(val, source is [.,S], target is [.,T]) == +; val = '_$fromCoerceable_$ => canCoerce(S,T) +; null (object := coerceInt1(mkObjWrap(val,source), ['List, T])) => +; coercionFailure() +; asTupleNew0 objValUnwrap object + +(DEFUN |L2Tuple| (|val| |source| |target|) + (PROG (T$ S |object|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |val| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((NULL + (SPADLET |object| + (|coerceInt1| + (|mkObjWrap| |val| |source|) + (CONS (QUOTE |List|) (CONS T$ NIL))))) + (|coercionFailure|)) + ((QUOTE T) (|asTupleNew0| (|objValUnwrap| |object|)))))))) + +;L2DP(l, source is [.,S], target is [.,n,T]) == +; -- need to know size of the list +; l = '_$fromCoerceable_$ => nil +; n ^= SIZE l => coercionFailure() +; (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),['Vector,T])) or +; coercionFailure() +; V2DP(objValUnwrap v, ['Vector, T], target) + +(DEFUN L2DP (|l| |source| |target|) + (PROG (|n| T$ S |v|) + (RETURN + (PROGN + (SPADLET |n| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |l| (QUOTE |$fromCoerceable$|)) NIL) + ((NEQUAL |n| (SIZE |l|)) (|coercionFailure|)) + ((QUOTE T) + (OR + (SPADLET |v| + (|coerceInt| + (|objNewWrap| (LIST2VEC |l|) (CONS (QUOTE |Vector|) (CONS S NIL))) + (CONS (QUOTE |Vector|) (CONS T$ NIL)))) + (|coercionFailure|)) + (V2DP + (|objValUnwrap| |v|) + (CONS (QUOTE |Vector|) (CONS T$ NIL)) + |target|))))))) + +;V2DP(v, source is [.,S], target is [.,n,T]) == +; -- need to know size of the vector +; v = '_$fromCoerceable_$ => nil +; n ^= SIZE v => coercionFailure() +; (v1 := coerceInt(objNewWrap(v,source),['Vector,T])) or +; coercionFailure() +; dpFun := getFunctionFromDomain('directProduct, target, [['Vector,T]]) +; SPADCALL(objValUnwrap v1, dpFun) + +(DEFUN V2DP (|v| |source| |target|) + (PROG (|n| T$ S |v1| |dpFun|) + (RETURN + (PROGN + (SPADLET |n| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |v| (QUOTE |$fromCoerceable$|)) NIL) + ((NEQUAL |n| (SIZE |v|)) (|coercionFailure|)) + ((QUOTE T) + (OR + (SPADLET |v1| + (|coerceInt| + (|objNewWrap| |v| |source|) + (CONS (QUOTE |Vector|) (CONS T$ NIL)))) + (|coercionFailure|)) + (SPADLET |dpFun| + (|getFunctionFromDomain| + (QUOTE |directProduct|) + |target| + (CONS (CONS (QUOTE |Vector|) (CONS T$ NIL)) NIL))) + (SPADCALL (|objValUnwrap| |v1|) |dpFun|))))))) + +;L2V(l, source is [.,S], target is [.,T]) == +; l = '_$fromCoerceable_$ => canCoerce(S,T) +; (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),target)) or +; coercionFailure() +; objValUnwrap(v) + +(DEFUN L2V (|l| |source| |target|) + (PROG (T$ S |v|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |l| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((QUOTE T) + (OR + (SPADLET |v| + (|coerceInt| + (|objNewWrap| (LIST2VEC |l|) (CONS (QUOTE |Vector|) (CONS S NIL))) + |target|)) + (|coercionFailure|)) + (|objValUnwrap| |v|))))))) + +;V2L(v, source is [.,S], target is [.,T]) == +; v = '_$fromCoerceable_$ => canCoerce(S,T) +; (l := coerceInt(objNewWrap(VEC2LIST v,['List,S]),target)) or +; coercionFailure() +; objValUnwrap(l) + +(DEFUN V2L (|v| |source| |target|) + (PROG (T$ S |l|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |v| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((QUOTE T) + (OR + (SPADLET |l| + (|coerceInt| + (|objNewWrap| + (VEC2LIST |v|) + (CONS (QUOTE |List|) (CONS S NIL))) + |target|)) + (|coercionFailure|)) + (|objValUnwrap| |l|))))))) + +;L2M(u,[.,D],[.,R]) == +; u = '_$fromCoerceable_$ => nil +; D is ['List,E] and isRectangularList(u,#u,# first u) => +; u' := nil +; for x in u repeat +; x' := nil +; for y in x repeat +; (y' := coerceInt(objNewWrap(y,E),R)) or coercionFailure() +; x' := [objValUnwrap(y'),:x'] +; u' := [LIST2VEC reverse x',:u'] +; LIST2VEC reverse u' +; coercionFailure() + +(DEFUN L2M (|u| #0=#:G167711 #1=#:G167722) + (PROG (R D |ISTMP#1| E |y'| |x'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET R (CADR #1#)) + (SPADLET D (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP D) + (EQ (QCAR D) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularList| |u| (|#| |u|) (|#| (CAR |u|)))) + (SPADLET |u'| NIL) + (DO ((#2=#:G167744 |u| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x'| NIL) + (DO ((#3=#:G167755 |x| (CDR #3#)) (|y| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |y| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (OR + (SPADLET |y'| (|coerceInt| (|objNewWrap| |y| E) R)) + (|coercionFailure|)) + (SPADLET |x'| (CONS (|objValUnwrap| |y'|) |x'|)))))) + (SPADLET |u'| (CONS (LIST2VEC (REVERSE |x'|)) |u'|)))))) + (LIST2VEC (REVERSE |u'|))) + ((QUOTE T) (|coercionFailure|)))))))) + +;L2Record(l,[.,D],[.,:al]) == +; l = '_$fromCoerceable_$ => nil +; #l = #al => +; v:= [u for x in l for [":",.,D'] in al] where u == +; T:= coerceInt(objNewWrap(x,D),D') or return 'failed +; objValUnwrap(T) +; v = 'failed => coercionFailure() +; #v = 2 => [v.0,:v.1] +; LIST2VEC v +; coercionFailure() + +(DEFUN |L2Record| (|l| #0=#:G167782 #1=#:G167791) + (PROG (|al| D |D'| T$ |v|) + (RETURN + (SEQ + (PROGN + (SPADLET |al| (CDR #1#)) + (SPADLET D (CADR #0#)) + (COND + ((BOOT-EQUAL |l| (QUOTE |$fromCoerceable$|)) NIL) + ((BOOT-EQUAL (|#| |l|) (|#| |al|)) + (SPADLET |v| + (PROG (#2=#:G167811) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167820 |l| (CDR #3#)) + (|x| NIL) + (#4=#:G167821 |al| (CDR #4#)) + (#5=#:G167774 NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |x| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN (PROGN (SPADLET |D'| (CADDR #5#)) #5#) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (PROGN + (SPADLET T$ + (OR + (|coerceInt| (|objNewWrap| |x| D) |D'|) + (RETURN (QUOTE |failed|)))) + (|objValUnwrap| T$)) + #2#)))))))) + (COND + ((BOOT-EQUAL |v| (QUOTE |failed|)) (|coercionFailure|)) + ((EQL (|#| |v|) 2) (CONS (ELT |v| 0) (ELT |v| 1))) + ((QUOTE T) (LIST2VEC |v|)))) + ((QUOTE T) (|coercionFailure|)))))))) + +;L2Rm(u,source is [.,D],target is [.,n,m,R]) == +; u = '_$fromCoerceable_$ => nil +; D is ['List,E] and isRectangularList(u,n,m) => +; L2M(u,source,['Matrix,R]) +; coercionFailure() + +(DEFUN |L2Rm| (|u| |source| |target|) + (PROG (|n| |m| R D |ISTMP#1| E) + (RETURN + (PROGN + (SPADLET |n| (CADR |target|)) + (SPADLET |m| (CADDR |target|)) + (SPADLET R (CADDDR |target|)) + (SPADLET D (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP D) + (EQ (QCAR D) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularList| |u| |n| |m|)) + (L2M |u| |source| (CONS (QUOTE |Matrix|) (CONS R NIL)))) + ((QUOTE T) (|coercionFailure|))))))) + +;L2Sm(u,source is [.,D],[.,n,R]) == +; u = '_$fromCoerceable_$ => nil +; D is ['List,E] and isRectangularList(u,n,n) => +; L2M(u,source,['Matrix,R]) +; coercionFailure() + +(DEFUN |L2Sm| (|u| |source| #0=#:G167896) + (PROG (|n| R D |ISTMP#1| E) + (RETURN + (PROGN + (SPADLET |n| (CADR #0#)) + (SPADLET R (CADDR #0#)) + (SPADLET D (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP D) + (EQ (QCAR D) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularList| |u| |n| |n|)) + (L2M |u| |source| (CONS (QUOTE |Matrix|) (CONS R NIL)))) + ((QUOTE T) (|coercionFailure|))))))) + +;L2Set(x,source is [.,S],target is [.,T]) == +; x = '_$fromCoerceable_$ => canCoerce(S,T) +; -- call library function brace to get a set +; target' := ['Set,S] +; u := objNewWrap( +; SPADCALL(x,getFunctionFromDomain('brace,target',[source])), +; target') +; (u := coerceInt(u,target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |L2Set| (|x| |source| |target|) + (PROG (T$ S |target'| |u|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((QUOTE T) + (SPADLET |target'| (CONS (QUOTE |Set|) (CONS S NIL))) + (SPADLET |u| + (|objNewWrap| + (SPADCALL |x| + (|getFunctionFromDomain| '|brace| |target'| (CONS |source| NIL))) + |target'|)) + (OR (SPADLET |u| (|coerceInt| |u| |target|)) (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;Set2L(x,source is [.,S],target is [.,T]) == +; x = '_$fromCoerceable_$ => canCoerce(S,T) +; -- call library function destruct to get a list +; u := objNewWrap( +; SPADCALL(x,getFunctionFromDomain('destruct,source,[source])), +; ['List,S]) +; (u := coerceInt(u,target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |Set2L| (|x| |source| |target|) + (PROG (T$ S |u|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((QUOTE T) + (SPADLET |u| + (|objNewWrap| + (SPADCALL |x| + (|getFunctionFromDomain| '|destruct| |source| (CONS |source| NIL))) + (CONS (QUOTE |List|) (CONS S NIL)))) + (OR (SPADLET |u| (|coerceInt| |u| |target|)) (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;Agg2Agg(x,source is [agg1,S],target is [.,T]) == +; x = '_$fromCoerceable_$ => canCoerce(S,T) +; S = T => coercionFailure() -- library function +; target' := [agg1,T] +; (u := coerceInt(objNewWrap(x,source),target')) or coercionFailure() +; (u := coerceInt(u,target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |Agg2Agg| (|x| |source| |target|) + (PROG (T$ |agg1| S |target'| |u|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |agg1| (CAR |source|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((BOOT-EQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |target'| (CONS |agg1| (CONS T$ NIL))) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |x| |source|) |target'|)) + (|coercionFailure|)) + (OR + (SPADLET |u| (|coerceInt| |u| |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;Agg2L2Agg(x,source is [.,S],target) == +; -- tries to use list as an intermediate type +; mid := ['List,S] +; x = '_$fromCoerceable_$ => +; canCoerce(source,mid) and canCoerce(mid,target) +; (u := coerceInt(objNewWrap(x,source),mid)) or coercionFailure() +; (u := coerceInt(u,target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |Agg2L2Agg| (|x| |source| |target|) + (PROG (S |mid| |u|) + (RETURN + (PROGN + (SPADLET S (CADR |source|)) + (SPADLET |mid| (CONS (QUOTE |List|) (CONS S NIL))) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) + (AND + (|canCoerce| |source| |mid|) + (|canCoerce| |mid| |target|))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |x| |source|) |mid|)) + (|coercionFailure|)) + (OR + (SPADLET |u| (|coerceInt| |u| |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;isRectangularList(x,p,q) == +; p=0 or p=#x => +; n:= #first x +; and/[n=#y for y in rest x] => p=0 or q=n + +(DEFUN |isRectangularList| (|x| |p| |q|) + (PROG (|n|) + (RETURN + (SEQ + (COND + ((OR (EQL |p| 0) (BOOT-EQUAL |p| (|#| |x|))) + (EXIT + (PROGN + (SPADLET |n| (|#| (CAR |x|))) + (COND + ((PROG (#0=#:G168010) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168016 NIL (NULL #0#)) + (#2=#:G168017 (CDR |x|) (CDR #2#)) + (|y| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |n| (|#| |y|))))))))) + (OR (EQL |p| 0) (BOOT-EQUAL |q| |n|)))))))))))) + +;--% Matrix +;M2L(x,[.,S],target) == +; mid := ['Vector,['Vector,S]] +; x = '_$fromCoerceable_$ => canCoerce(mid,target) +; (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() +; objValUnwrap u + +(DEFUN M2L (|x| #0=#:G168030 |target|) + (PROG (S |mid| |u|) + (RETURN + (PROGN + (SPADLET S (CADR #0#)) + (SPADLET |mid| + (CONS (QUOTE |Vector|) (CONS (CONS (QUOTE |Vector|) (CONS S NIL)) NIL))) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| |mid| |target|)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |x| |mid|) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;M2M(x,[.,R],[.,S]) == +; x = '_$fromCoerceable_$ => canCoerce(R,S) +; n := # x +; m := # x.0 +; v := nil +; for i in 0..(n-1) repeat +; u := nil +; for j in 0..(m-1) repeat +; y := x.i.j +; (y' := coerceInt(objNewWrap(y,R),S)) or coercionFailure() +; u := [objValUnwrap y',:u] +; v := [LIST2VEC reverse u,:v] +; LIST2VEC reverse v + +(DEFUN M2M (|x| #0=#:G168046 #1=#:G168053) + (PROG (S R |n| |m| |y| |y'| |u| |v|) + (RETURN + (SEQ + (PROGN + (SPADLET S (CADR #1#)) + (SPADLET R (CADR #0#)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| R S)) + ((QUOTE T) + (SPADLET |n| (|#| |x|)) + (SPADLET |m| (|#| (ELT |x| 0))) + (SPADLET |v| NIL) + (DO ((#2=#:G168072 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #2#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |u| NIL) + (DO ((#3=#:G168082 (SPADDIFFERENCE |m| 1)) (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| #3#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |y| (ELT (ELT |x| |i|) |j|)) + (OR + (SPADLET |y'| (|coerceInt| (|objNewWrap| |y| R) S)) + (|coercionFailure|)) + (SPADLET |u| (CONS (|objValUnwrap| |y'|) |u|)))))) + (SPADLET |v| (CONS (LIST2VEC (REVERSE |u|)) |v|)))))) + (LIST2VEC (REVERSE |v|))))))))) + +;M2Rm(x,source is [.,R],[.,p,q,S]) == +; x = '_$fromCoerceable_$ => nil +; n:= #x +; m:= #x.0 +; n=p and m=q => M2M(x,source,[nil,S]) +; coercionFailure() + +(DEFUN |M2Rm| (|x| |source| #0=#:G168106) + (PROG (|p| |q| S R |n| |m|) + (RETURN + (PROGN + (SPADLET |p| (CADR #0#)) + (SPADLET |q| (CADDR #0#)) + (SPADLET S (CADDDR #0#)) + (SPADLET R (CADR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) + (SPADLET |n| (|#| |x|)) + (SPADLET |m| (|#| (ELT |x| 0))) + (COND + ((AND (BOOT-EQUAL |n| |p|) (BOOT-EQUAL |m| |q|)) + (M2M |x| |source| (CONS NIL (CONS S NIL)))) + ((QUOTE T) (|coercionFailure|))))))))) + +;M2Sm(x,source is [.,R],[.,p,S]) == +; x = '_$fromCoerceable_$ => nil +; n:= #x +; m:= #x.(0) +; n=m and m=p => M2M(x,source,[nil,S]) +; coercionFailure() + +(DEFUN |M2Sm| (|x| |source| #0=#:G168136) + (PROG (|p| S R |n| |m|) + (RETURN + (PROGN + (SPADLET |p| (CADR #0#)) + (SPADLET S (CADDR #0#)) + (SPADLET R (CADR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) + (SPADLET |n| (|#| |x|)) + (SPADLET |m| (|#| (ELT |x| 0))) + (COND + ((AND (BOOT-EQUAL |n| |m|) (BOOT-EQUAL |m| |p|)) + (M2M |x| |source| (CONS NIL (CONS S NIL)))) + ((QUOTE T) (|coercionFailure|))))))))) + +;M2V(x,[.,S],target) == +; mid := ['Vector,['Vector,S]] +; x = '_$fromCoerceable_$ => canCoerce(mid,target) +; (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() +; objValUnwrap u + +(DEFUN M2V (|x| #0=#:G168157 |target|) + (PROG (S |mid| |u|) + (RETURN + (PROGN + (SPADLET S (CADR #0#)) + (SPADLET |mid| + (CONS (QUOTE |Vector|) (CONS (CONS (QUOTE |Vector|) (CONS S NIL)) NIL))) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) (|canCoerce| |mid| |target|)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |x| |mid|) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;--% Multivariate Polynomial +;Mp2Dmp(u, source is [., x, S], target is [dmp, y, T]) == +; -- Change the representation to a DMP with the same variables and +; -- coerce. +; target' := [dmp,x,S] +; u = '_$fromCoerceable_$ => canCoerce(target',target) +; -- check if we have a constant +; u is [ =0,:c] => +; null (u' := coerceInt(objNewWrap(c,S),target)) => +; coercionFailure() +; objValUnwrap(u') +; plus := getFunctionFromDomain('_+,target',[target',target']) +; mult := getFunctionFromDomain('_*,target',[target',target']) +; one := domainOne(S) +; zero := domainZero(S) +; (u' := coerceInt(objNewWrap(Mp2SimilarDmp(u,S,#x,plus,mult,one,zero), +; target'),target)) or coercionFailure() +; objValUnwrap(u') + +(DEFUN |Mp2Dmp| (|u| |source| |target|) + (PROG (|dmp| |y| T$ |x| S |target'| |c| |plus| |mult| |one| |zero| |u'|) + (RETURN + (PROGN + (SPADLET |dmp| (CAR |target|)) + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (SPADLET |target'| (CONS |dmp| (CONS |x| (CONS S NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (|canCoerce| |target'| |target|)) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (COND + ((NULL (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |u'|)))) + ((QUOTE T) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target'| + (CONS |target'| (CONS |target'| NIL)))) + (SPADLET |mult| + (|getFunctionFromDomain| + (QUOTE *) + |target'| + (CONS |target'| (CONS |target'| NIL)))) + (SPADLET |one| (|domainOne| S)) + (SPADLET |zero| (|domainZero| S)) + (OR + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| + (|Mp2SimilarDmp| |u| S (|#| |x|) |plus| |mult| |one| |zero|) + |target'|) + |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|))))))) + +;Mp2SimilarDmp(u,S,n,plus,mult,one,zero) == +; u is [ =0,:c] => +; c = zero => NIL -- zero for dmp +; [[LIST2VEC LZeros n,:c]] +; u is [ =1,x,:terms] => +; u' := NIL -- zero for dmp +; for [e,:c] in terms repeat +; e' := LIST2VEC LZeros n +; e'.(x-1) := e +; t := [[e',:one]] +; t := SPADCALL(t,Mp2SimilarDmp(c,S,n,plus,mult,one,zero),mult) +; u' := SPADCALL(u',t,plus) +; u' + +(DEFUN |Mp2SimilarDmp| (|u| S |n| |plus| |mult| |one| |zero|) + (PROG (|ISTMP#1| |x| |terms| |e| |c| |e'| |t| |u'|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (COND + ((BOOT-EQUAL |c| |zero|) NIL) + ((QUOTE T) + (CONS (CONS (LIST2VEC (|LZeros| |n|)) |c|) NIL)))) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |terms| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SPADLET |u'| NIL) + (DO ((#0=#:G168239 |terms| (CDR #0#)) (#1=#:G168224 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |e'| (LIST2VEC (|LZeros| |n|))) + (SETELT |e'| (SPADDIFFERENCE |x| 1) |e|) + (SPADLET |t| (CONS (CONS |e'| |one|) NIL)) + (SPADLET |t| + (SPADCALL |t| + (|Mp2SimilarDmp| |c| S |n| |plus| |mult| |one| |zero|) + |mult|)) + (SPADLET |u'| (SPADCALL |u'| |t| |plus|)))))) + |u'|)))))) + +;Mp2Expr(u,source is [mp,vars,S], target is [Expr,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S, target) +; dmp := ['DistributedMultivariatePolynomial, vars, S] +; not (d := coerceInt(objNewWrap(u, source), dmp)) => coercionFailure() +; Dmp2Expr(objValUnwrap d, dmp, target) + +(DEFUN |Mp2Expr| (|u| |source| |target|) + (PROG (|Expr| T$ |mp| |vars| S |dmp| |d|) + (RETURN + (PROGN + (SPADLET |Expr| (CAR |target|)) + (SPADLET T$ (CADR |target|)) + (SPADLET |mp| (CAR |source|)) + (SPADLET |vars| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((QUOTE T) + (SPADLET |dmp| + (CONS + (QUOTE |DistributedMultivariatePolynomial|) + (CONS |vars| (CONS S NIL)))) + (COND + ((NULL (SPADLET |d| (|coerceInt| (|objNewWrap| |u| |source|) |dmp|))) + (|coercionFailure|)) + ((QUOTE T) + (|Dmp2Expr| (|objValUnwrap| |d|) |dmp| |target|))))))))) + +;Mp2FR(u,S is [.,vl,R],[.,T]) == +; u = '_$fromCoerceable_$ => +; S ^= T => nil +; R in '((Integer) (Fraction (Integer))) => true +; nil +; S ^= T => coercionFailure() +; package := +; R = $Integer => +; ovl := ['OrderedVariableList, vl] +; ['MultivariateFactorize,ovl, ['IndexedExponents, ovl],R,S] +; R is ['Fraction, D] => +; ovl := ['OrderedVariableList, vl] +; package := ['MRationalFactorize,['IndexedExponents, ovl], ovl, D, S] +; coercionFailure() +; factor := getFunctionFromDomain('factor,package,[S]) +; SPADCALL(u,factor) + +(DEFUN |Mp2FR| (|u| S #0=#:G168315) + (PROG (T$ |vl| R |ISTMP#1| D |ovl| |package| |factor|) + (RETURN + (PROGN + (SPADLET T$ (CADR #0#)) + (SPADLET |vl| (CADR S)) + (SPADLET R (CADDR S)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((NEQUAL S T$) NIL) + ((|member| R (QUOTE ((|Integer|) (|Fraction| (|Integer|))))) (QUOTE T)) + ((QUOTE T) NIL))) + ((NEQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |package| + (COND + ((BOOT-EQUAL R |$Integer|) + (SPADLET |ovl| (CONS (QUOTE |OrderedVariableList|) (CONS |vl| NIL))) + (CONS + (QUOTE |MultivariateFactorize|) + (CONS |ovl| + (CONS + (CONS (QUOTE |IndexedExponents|) (CONS |ovl| NIL)) + (CONS R (CONS S NIL)))))) + ((AND (PAIRP R) + (EQ (QCAR R) (QUOTE |Fraction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR R)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |ovl| (CONS (QUOTE |OrderedVariableList|) (CONS |vl| NIL))) + (SPADLET |package| + (CONS + (QUOTE |MRationalFactorize|) + (CONS + (CONS (QUOTE |IndexedExponents|) (CONS |ovl| NIL)) + (CONS |ovl| (CONS D (CONS S NIL))))))) + ((QUOTE T) (|coercionFailure|)))) + (SPADLET |factor| + (|getFunctionFromDomain| (QUOTE |factor|) |package| (CONS S NIL))) + (SPADCALL |u| |factor|))))))) + +;Mp2Mp(u,source is [mp,x,S], target is [.,y,T]) == +; -- need not deal with case of x = y (coerceByMapping) +; common := INTERSECTION(y,x) +; x' := SETDIFFERENCE(x,common) +; y' := SETDIFFERENCE(y,common) +; u = '_$fromCoerceable_$ => +; x = y => canCoerce(S,T) +; null common => canCoerce(source,T) +; null x' => canCoerce(S,target) +; null y' => canCoerce([mp,x',S],T) +; canCoerce([mp,x',S],[mp,y',T]) +; -- first check for constant case +; u is [ =0,:c] => +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; plus := getFunctionFromDomain('_+,target,[target,target]) +; -- now no-common-variables case +; null common => +; times := getFunctionFromDomain('_*,target,[target,target]) +; expn := getFunctionFromDomain('_*_*,target, +; [target,$NonNegativeInteger]) +; Mp2MpAux0(u,S,target,x,plus,times,expn) +; -- if source vars are all in target +; null x' => +; monom := getFunctionFromDomain('monomial,target, +; [target,['OrderedVariableList,y],$NonNegativeInteger]) +; Mp2MpAux1(u,S,target,x,y,plus,monom) +; -- if target vars are all in source +; null y' => -- change source to MP[common] MP[x'] S +; univariate := getFunctionFromDomain('univariate, +; source,[source,['OrderedVariableList,x]]) +; u' := Mp2MpAux2(u,x,common,x',common,x',univariate,S,NIL) +; (u' := coerceInt(objNewWrap(u', [mp,common,[mp,x',S]]),target)) or +; coercionFailure() +; objValUnwrap(u') +; -- we have a mixture +; (u' := coerceInt(objNewWrap(u,source),[mp,common,[mp,x',S]])) or +; coercionFailure() +; (u' := coerceInt(u',target)) or coercionFailure() +; objValUnwrap(u') + +(DEFUN |Mp2Mp| (|u| |source| |target|) + (PROG (|y| T$ |mp| |x| S |common| |x'| |y'| |c| |plus| |times| |expn| + |monom| |univariate| |u'|) + (RETURN + (PROGN + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |mp| (CAR |source|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (SPADLET |common| (|intersection| |y| |x|)) + (SPADLET |x'| (SETDIFFERENCE |x| |common|)) + (SPADLET |y'| (SETDIFFERENCE |y| |common|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((BOOT-EQUAL |x| |y|) (|canCoerce| S T$)) + ((NULL |common|) (|canCoerce| |source| T$)) + ((NULL |x'|) (|canCoerce| S |target|)) + ((NULL |y'|) (|canCoerce| (CONS |mp| (CONS |x'| (CONS S NIL))) T$)) + ((QUOTE T) + (|canCoerce| + (CONS |mp| (CONS |x'| (CONS S NIL))) + (CONS |mp| (CONS |y'| (CONS T$ NIL))))))) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (COND + ((NULL |common|) + (SPADLET |times| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |expn| + (|getFunctionFromDomain| + (QUOTE **) + |target| + (CONS |target| (CONS |$NonNegativeInteger| NIL)))) + (|Mp2MpAux0| |u| S |target| |x| |plus| |times| |expn|)) + ((NULL |x'|) + (SPADLET |monom| + (|getFunctionFromDomain| + (QUOTE |monomial|) + |target| + (CONS + |target| + (CONS + (CONS (QUOTE |OrderedVariableList|) (CONS |y| NIL)) + (CONS |$NonNegativeInteger| NIL))))) + (|Mp2MpAux1| |u| S |target| |x| |y| |plus| |monom|)) + ((NULL |y'|) + (SPADLET |univariate| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| + (CONS |source| + (CONS (CONS (QUOTE |OrderedVariableList|) (CONS |x| NIL)) NIL)))) + (SPADLET |u'| + (|Mp2MpAux2| |u| |x| |common| |x'| |common| |x'| |univariate| S NIL)) + (OR + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u'| + (CONS |mp| + (CONS |common| (CONS (CONS |mp| (CONS |x'| (CONS S NIL))) NIL)))) + |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (OR + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u| |source|) + (CONS |mp| + (CONS |common| (CONS (CONS |mp| (CONS |x'| (CONS S NIL))) NIL))))) + (|coercionFailure|)) + (OR (SPADLET |u'| (|coerceInt| |u'| |target|)) (|coercionFailure|)) + (|objValUnwrap| |u'|))))))))) + +;Mp2MpAux0(u,S,target,vars,plus,times,expn) == +; -- for case when no common variables +; u is [ =0,:c] => +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; [.,var,:terms] := u +; [mp,.,T] := target +; x := coerceInt(objNewWrap(vars.(var-1),['Variable,vars.(var-1)]), +; [mp,vars,$Integer]) or coercionFailure() +; (x := coerceInt(x,T)) or coercionFailure() +; x := [0,:objValUnwrap x] +; sum := domainZero(target) +; for [e,:c] in terms repeat +; prod := SPADCALL(SPADCALL(x,e,expn), +; Mp2MpAux0(c,S,target,vars,plus,times,expn),times) +; sum := SPADCALL(sum,prod,plus) +; sum + +(DEFUN |Mp2MpAux0| (|u| S |target| |vars| |plus| |times| |expn|) + (PROG (|u'| |var| |terms| |mp| T$ |x| |e| |c| |prod| |sum|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |var| (CADR |u|)) + (SPADLET |terms| (CDDR |u|)) + (SPADLET |mp| (CAR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |x| + (OR + (|coerceInt| + (|objNewWrap| + (ELT |vars| (SPADDIFFERENCE |var| 1)) + (CONS + (QUOTE |Variable|) + (CONS (ELT |vars| (SPADDIFFERENCE |var| 1)) NIL))) + (CONS |mp| (CONS |vars| (CONS |$Integer| NIL)))) + (|coercionFailure|))) + (OR (SPADLET |x| (|coerceInt| |x| T$)) (|coercionFailure|)) + (SPADLET |x| (CONS 0 (|objValUnwrap| |x|))) + (SPADLET |sum| (|domainZero| |target|)) + (DO ((#0=#:G168417 |terms| (CDR #0#)) (#1=#:G168406 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |prod| + (SPADCALL + (SPADCALL |x| |e| |expn|) + (|Mp2MpAux0| |c| S |target| |vars| |plus| |times| |expn|) + |times|)) + (SPADLET |sum| (SPADCALL |sum| |prod| |plus|)))))) + |sum|)))))) + +;Mp2MpAux1(u,S,target,varl1,varl2,plus,monom) == +; -- for case when source vars are all in target +; u is [ =0,:c] => +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; [.,var,:terms] := u +; sum := domainZero(target) +; for [e,:c] in terms repeat +; mon := SPADCALL( Mp2MpAux1(c,S,target,varl1,varl2,plus,monom), +; position1(varl1.(var-1), varl2),e,monom) +; sum := SPADCALL(sum,mon,plus) +; sum + +(DEFUN |Mp2MpAux1| (|u| S |target| |varl1| |varl2| |plus| |monom|) + (PROG (|u'| |var| |terms| |e| |c| |mon| |sum|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |var| (CADR |u|)) + (SPADLET |terms| (CDDR |u|)) + (SPADLET |sum| (|domainZero| |target|)) + (DO ((#0=#:G168457 |terms| (CDR #0#)) (#1=#:G168446 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |mon| + (SPADCALL + (|Mp2MpAux1| |c| S |target| |varl1| |varl2| |plus| |monom|) + (|position1| (ELT |varl1| (SPADDIFFERENCE |var| 1)) |varl2|) + |e| |monom|)) + (SPADLET |sum| (SPADCALL |sum| |mon| |plus|)))))) + |sum|)))))) + +;Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) == +; -- target vars are all in source +; mp2 := ['MultivariatePolynomial,oldcomm,['MultivariatePolynomial, +; oldrest,S]] +; common => +; u is [ =0,:c] => +; (u' := coerceInt(objNewWrap(c,S),mp2)) or coercionFailure() +; objValUnwrap(u') +; [var,:common] := common +; u' := SPADCALL(u,position1(var,x),univariate) +; null(rest(u')) and (first(first(u')) = 0) => +; Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) +; [1,position1(var,oldcomm),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, +; common,restvars,univariate,S,isUnder)] for [e,:c] in u']] +; null isUnder => +; [0,:Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,true)] +; -- just treat like elt of [mp,x',S] +; u is [ =0,:c] => u +; [var,:restvars] := restvars +; u' := SPADCALL(u,position1(var,x),univariate) +; null(rest(u')) and (first(first(u')) = 0) => +; Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) +; [1,position1(var,oldrest),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, +; common,restvars,univariate,S,isUnder)] for [e,:c] in u']] + +(DEFUN |Mp2MpAux2| (|u| |x| |oldcomm| |oldrest| |common| |restvars| + |univariate| S |isUnder|) + (PROG (|mp2| |LETTMP#1| |var| |u'| |e| |c|) + (RETURN + (SEQ + (PROGN + (SPADLET |mp2| + (CONS + (QUOTE |MultivariatePolynomial|) + (CONS |oldcomm| + (CONS + (CONS (QUOTE |MultivariatePolynomial|) (CONS |oldrest| (CONS S NIL))) + NIL)))) + (COND + (|common| + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |mp2|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |LETTMP#1| |common|) + (SPADLET |var| (CAR |LETTMP#1|)) + (SPADLET |common| (CDR |LETTMP#1|)) + (SPADLET |u'| (SPADCALL |u| (|position1| |var| |x|) |univariate|)) + (COND + ((AND (NULL (CDR |u'|)) (EQL (CAR (CAR |u'|)) 0)) + (|Mp2MpAux2| |u| |x| |oldcomm| |oldrest| |common| |restvars| + |univariate| S |isUnder|)) + ((QUOTE T) + (CONS 1 + (CONS + (|position1| |var| |oldcomm|) + (PROG (#0=#:G168506) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168512 |u'| (CDR #1#)) (#2=#:G168484 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #2#)) + (SPADLET |c| (CDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS |e| + (|Mp2MpAux2| |c| |x| |oldcomm| |oldrest| |common| + |restvars| |univariate| S |isUnder|)) + #0#)))))))))))))) + ((NULL |isUnder|) + (CONS 0 + (|Mp2MpAux2| |u| |x| |oldcomm| |oldrest| |common| |restvars| + |univariate| S (QUOTE T)))) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + |u|) + ((QUOTE T) + (SPADLET |LETTMP#1| |restvars|) + (SPADLET |var| (CAR |LETTMP#1|)) + (SPADLET |restvars| (CDR |LETTMP#1|)) + (SPADLET |u'| (SPADCALL |u| (|position1| |var| |x|) |univariate|)) + (COND + ((AND (NULL (CDR |u'|)) (EQL (CAR (CAR |u'|)) 0)) + (|Mp2MpAux2| |u| |x| |oldcomm| |oldrest| |common| |restvars| + |univariate| S |isUnder|)) + ((QUOTE T) + (CONS 1 + (CONS + (|position1| |var| |oldrest|) + (PROG (#3=#:G168524) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G168530 |u'| (CDR #4#)) (#5=#:G168496 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #5#)) + (SPADLET |c| (CDR #5#)) #5#) + NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS + (CONS |e| + (|Mp2MpAux2| |c| |x| |oldcomm| |oldrest| |common| + |restvars| |univariate| S |isUnder|)) + #3#)))))))))))))))))) + +;genMpFromDmpTerm(u, oldlen) == +; -- given one term of a DMP representation of a polynomial, this creates +; -- the corresponding MP term. +; patlen := oldlen +; [e,:c] := u +; numexps := # e +; patlen >= numexps => [0, :c] +; for i in patlen..(numexps - 1) repeat +; e.i = 0 => patlen := patlen + 1 +; return nil +; patlen >= numexps => [0, :c] +; [1, 1+patlen, [e.patlen,:genMpFromDmpTerm(u,patlen+1)]] + +(DEFUN |genMpFromDmpTerm| (|u| |oldlen|) + (PROG (|e| |c| |numexps| |patlen|) + (RETURN + (SEQ + (PROGN + (SPADLET |patlen| |oldlen|) + (SPADLET |e| (CAR |u|)) + (SPADLET |c| (CDR |u|)) + (SPADLET |numexps| (|#| |e|)) + (COND + ((>= |patlen| |numexps|) (CONS 0 |c|)) + ((QUOTE T) + (DO ((#0=#:G168566 (SPADDIFFERENCE |numexps| 1)) + (|i| |patlen| (+ |i| 1))) + ((> |i| #0#) NIL) + (SEQ + (EXIT + (COND + ((EQL (ELT |e| |i|) 0) (SPADLET |patlen| (PLUS |patlen| 1))) + ((QUOTE T) (RETURN NIL)))))) + (COND + ((>= |patlen| |numexps|) (CONS 0 |c|)) + ((QUOTE T) + (CONS 1 + (CONS + (PLUS 1 |patlen|) + (CONS + (CONS + (ELT |e| |patlen|) + (|genMpFromDmpTerm| |u| (PLUS |patlen| 1))) + NIL)))))))))))) + +;Mp2P(u, source is [mp,vl, S], target is [p,R]) == +; u = '_$fromCoerceable_$ => canCoerce(S,target) +; S is ['Polynomial,.] => MpP2P(u,vl,S,R) +; vl' := REVERSE MSORT vl +; -- if Mp2Mp fails, a THROW will occur +; u' := Mp2Mp(u,source,[mp,vl',S]) +; u' := translateMpVars2PVars (u',vl') +; (u' := coerceInt(objNewWrap(u',[p,S]),target)) or coercionFailure() +; objValUnwrap(u') + +(DEFUN |Mp2P| (|u| |source| |target|) + (PROG (|p| R |mp| |vl| S |ISTMP#1| |vl'| |u'|) + (RETURN + (PROGN + (SPADLET |p| (CAR |target|)) + (SPADLET R (CADR |target|)) + (SPADLET |mp| (CAR |source|)) + (SPADLET |vl| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((AND (PAIRP S) + (EQ (QCAR S) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR S)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (|MpP2P| |u| |vl| S R)) + ((QUOTE T) + (SPADLET |vl'| (REVERSE (MSORT |vl|))) + (SPADLET |u'| + (|Mp2Mp| |u| |source| (CONS |mp| (CONS |vl'| (CONS S NIL))))) + (SPADLET |u'| (|translateMpVars2PVars| |u'| |vl'|)) + (OR + (SPADLET |u'| + (|coerceInt| (|objNewWrap| |u'| (CONS |p| (CONS S NIL))) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|))))))) + +;MpP2P(u,vl,PS,R) == +; -- u has type MP(vl,PS). Want to coerce to P R. +; PR := ['Polynomial,R] +; u is [ =0,:c] => +; (u' :=coerceInt(objNewWrap(c,PS),PR)) or +; coercionFailure() +; objValUnwrap u' +; [ .,pos,:ec] := u +; multivariate := getFunctionFromDomain('multivariate, +; PR,[['SparseUnivariatePolynomial,PR],$Symbol]) +; sup := [[e,:MpP2P(c,vl,PS,R)] for [e,:c] in ec] +; p := SPADCALL(sup,vl.(pos-1),multivariate) + +(DEFUN |MpP2P| (|u| |vl| PS R) + (PROG (PR |u'| |pos| |ec| |multivariate| |e| |c| |sup| |p|) + (RETURN + (SEQ + (PROGN + (SPADLET PR (CONS (QUOTE |Polynomial|) (CONS R NIL))) + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| PS) PR)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |pos| (CADR |u|)) + (SPADLET |ec| (CDDR |u|)) + (SPADLET |multivariate| + (|getFunctionFromDomain| + (QUOTE |multivariate|) + PR + (CONS + (CONS (QUOTE |SparseUnivariatePolynomial|) (CONS PR NIL)) + (CONS |$Symbol| NIL)))) + (SPADLET |sup| + (PROG (#0=#:G168635) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168641 |ec| (CDR #1#)) (#2=#:G168625 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #2#)) + (SPADLET |c| (CDR #2#)) #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (CONS |e| (|MpP2P| |c| |vl| PS R)) #0#)))))))) + (SPADLET |p| + (SPADCALL |sup| + (ELT |vl| (SPADDIFFERENCE |pos| 1)) |multivariate|))))))))) + +; --(p' :=coerceInt(objNewWrap(p,PS),['Polynomial,R])) or coercionFailure() +; --objValUnwrap(p') +;Mp2Up(u,source is [mp,vl,S],target is [up,x,T]) == +; u = '_$fromCoerceable_$ => +; member(x,vl) => +; vl = [x] => canCoerce(S,T) +; canCoerce([mp,DELETE(x,vl),S],T) +; canCoerce(source,T) +; u is [ =0,:c] => -- constant polynomial? +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap u' +; null MEMBER(x,vl) => +; (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() +; [[0,:objValUnwrap(u')]] +; vl = [x] => +; u' := [[e,:c] for [e,.,:c] in CDDR u] +; (u' := coerceInt(objNewWrap(u',[up,x,S]),target)) +; or coercionFailure() +; objValUnwrap u' +; -- do a univariate to transform u to a UP(x,P S) and then coerce again +; var := position1(x,vl) +; UPP := ['UnivariatePolynomial,x,source] +; univariate := getFunctionFromDomain('univariate, +; source,[source,['OrderedVariableList,vl]]) +; upU := SPADCALL(u,var,univariate) -- we may assume this has type UPP +; (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() +; objValUnwrap u' + +(DEFUN |Mp2Up| (|u| |source| |target|) + (PROG (|up| |x| T$ |mp| |vl| S |e| |c| |var| UPP |univariate| |upU| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |up| (CAR |target|)) + (SPADLET |x| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |mp| (CAR |source|)) + (SPADLET |vl| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((|member| |x| |vl|) + (COND + ((BOOT-EQUAL |vl| (CONS |x| NIL)) (|canCoerce| S T$)) + ((QUOTE T) + (|canCoerce| + (CONS |mp| (CONS (|delete| |x| |vl|) (CONS S NIL))) + T$)))) + ((QUOTE T) (|canCoerce| |source| T$)))) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((NULL (|member| |x| |vl|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u'|)) NIL)) + ((BOOT-EQUAL |vl| (CONS |x| NIL)) + (SPADLET |u'| + (PROG (#0=#:G168712) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168718 (CDDR |u|) (CDR #1#)) (#2=#:G168666 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #2#)) + (SPADLET |c| (CDDR #2#)) #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |e| |c|) #0#)))))))) + (OR + (SPADLET |u'| + (|coerceInt| + (|objNewWrap| |u'| (CONS |up| (CONS |x| (CONS S NIL)))) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |var| (|position1| |x| |vl|)) + (SPADLET UPP + (CONS (QUOTE |UnivariatePolynomial|) (CONS |x| (CONS |source| NIL)))) + (SPADLET |univariate| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| + (CONS |source| + (CONS (CONS (QUOTE |OrderedVariableList|) (CONS |vl| NIL)) NIL)))) + (SPADLET |upU| (SPADCALL |u| |var| |univariate|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |upU| UPP) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)))))))) + +;--% OrderedVariableList +;OV2OV(u,source is [.,svl], target is [.,tvl]) == +; svl = INTERSECTION(svl,tvl) => +; u = '_$fromCoerceable_$ => true +; position1(svl.(u-1),tvl) +; u = '_$fromCoerceable_$ => nil +; coercionFailure() + +(DEFUN OV2OV (|u| |source| |target|) + (PROG (|tvl| |svl|) + (RETURN + (PROGN + (SPADLET |tvl| (CADR |target|)) + (SPADLET |svl| (CADR |source|)) + (COND + ((BOOT-EQUAL |svl| (|intersection| |svl| |tvl|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) (|position1| (ELT |svl| (SPADDIFFERENCE |u| 1)) |tvl|)))) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) (|coercionFailure|))))))) + +;OV2P(u,source is [.,svl], target is [.,T]) == +; u = '_$fromCoerceable_$ => true +; v := svl.(unwrap(u)-1) +; [1,v,[1,0,:domainOne(T)]] + +(DEFUN OV2P (|u| |source| |target|) + (PROG (T$ |svl| |v|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |svl| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) + (SPADLET |v| (ELT |svl| (SPADDIFFERENCE (|unwrap| |u|) 1))) + (CONS 1 (CONS |v| (CONS (CONS 1 (CONS 0 (|domainOne| T$))) NIL))))))))) + +;OV2poly(u,source is [.,svl], target is [p,vl,T]) == +; u = '_$fromCoerceable_$ => +; p = 'UnivariatePolynomial => (# svl = 1) and (p = svl.0) +; and/[MEMBER(v,vl) for v in svl] +; v := svl.(unwrap(u)-1) +; val' := [1,:domainOne(T)] +; p = 'UnivariatePolynomial => +; v ^= vl => coercionFailure() +; [[1,:domainOne(T)]] +; null MEMBER(v,vl) => coercionFailure() +; val' := [[1,:domainOne(T)]] +; source' := ['UnivariatePolynomial,v,T] +; (u' := coerceInt(objNewWrap(val',source'),target)) or +; coercionFailure() +; objValUnwrap(u') + +(DEFUN |OV2poly| (|u| |source| |target|) + (PROG (|p| |vl| T$ |svl| |v| |val'| |source'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |p| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |svl| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((BOOT-EQUAL |p| (QUOTE |UnivariatePolynomial|)) + (AND (EQL (|#| |svl|) 1) (BOOT-EQUAL |p| (ELT |svl| 0)))) + ((QUOTE T) + (PROG (#0=#:G168813) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168819 NIL (NULL #0#)) + (#2=#:G168820 |svl| (CDR #2#)) + (|v| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |v| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|member| |v| |vl|))))))))))) + ((QUOTE T) + (SPADLET |v| (ELT |svl| (SPADDIFFERENCE (|unwrap| |u|) 1))) + (SPADLET |val'| (CONS 1 (|domainOne| T$))) + (COND + ((BOOT-EQUAL |p| (QUOTE |UnivariatePolynomial|)) + (COND + ((NEQUAL |v| |vl|) (|coercionFailure|)) + ((QUOTE T) (CONS (CONS 1 (|domainOne| T$)) NIL)))) + ((NULL (|member| |v| |vl|)) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |val'| (CONS (CONS 1 (|domainOne| T$)) NIL)) + (SPADLET |source'| + (CONS (QUOTE |UnivariatePolynomial|) (CONS |v| (CONS T$ NIL)))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |val'| |source'|) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)))))))))) + +;OV2SE(u,source is [.,svl], target) == +; u = '_$fromCoerceable_$ => true +; svl.(unwrap(u)-1) + +(DEFUN OV2SE (|u| |source| |target|) + (PROG (|svl|) + (RETURN + (PROGN + (SPADLET |svl| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) (ELT |svl| (SPADDIFFERENCE (|unwrap| |u|) 1)))))))) + +;OV2Sy(u,source is [.,svl], target) == +; u = '_$fromCoerceable_$ => true +; svl.(unwrap(u)-1) + +(DEFUN |OV2Sy| (|u| |source| |target|) + (PROG (|svl|) + (RETURN + (PROGN + (SPADLET |svl| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) (ELT |svl| (SPADDIFFERENCE (|unwrap| |u|) 1)))))))) + +;--% Polynomial +;varsInPoly(u) == +; u is [ =1, v, :termlist] => +; [v,:varsInPoly(c) for [e,:c] in termlist] +; nil + +(DEFUN |varsInPoly| (|u|) + (PROG (|ISTMP#1| |v| |termlist| |e| |c|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |termlist| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (PROG (#0=#:G168875) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168881 |termlist| (CDR #1#)) (#2=#:G168870 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #2#)) (SPADLET |c| (CDR #2#)) #2#) + NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (APPEND #0# (CONS |v| (|varsInPoly| |c|)))))))))) + ((QUOTE T) NIL)))))) + +;P2FR(u,S is [.,R],[.,T]) == +; u = '_$fromCoerceable_$ => +; S ^= T => nil +; R in '((Integer) (Fraction (Integer))) => true +; nil +; S ^= T => coercionFailure() +; package := +; R = $Integer => +; ['MultivariateFactorize,$Symbol,['IndexedExponents, $Symbol],R,S] +; R is ['Fraction, D] => +; package := ['MRationalFactorize,['IndexedExponents, $Symbol],$Symbol, +; D, S] +; coercionFailure() +; factor := getFunctionFromDomain('factor,package,[S]) +; SPADCALL(u,factor) + +(DEFUN P2FR (|u| S #0=#:G168914) + (PROG (T$ R |ISTMP#1| D |package| |factor|) + (RETURN + (PROGN + (SPADLET T$ (CADR #0#)) + (SPADLET R (CADR S)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((NEQUAL S T$) NIL) + ((|member| R (QUOTE ((|Integer|) (|Fraction| (|Integer|))))) (QUOTE T)) + ((QUOTE T) NIL))) + ((NEQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |package| + (COND + ((BOOT-EQUAL R |$Integer|) + (CONS + (QUOTE |MultivariateFactorize|) + (CONS + |$Symbol| + (CONS + (CONS (QUOTE |IndexedExponents|) (CONS |$Symbol| NIL)) + (CONS R (CONS S NIL)))))) + ((AND (PAIRP R) + (EQ (QCAR R) (QUOTE |Fraction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR R)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |package| + (CONS + (QUOTE |MRationalFactorize|) + (CONS + (CONS (QUOTE |IndexedExponents|) (CONS |$Symbol| NIL)) + (CONS |$Symbol| (CONS D (CONS S NIL))))))) + ((QUOTE T) (|coercionFailure|)))) + (SPADLET |factor| + (|getFunctionFromDomain| (QUOTE |factor|) |package| (CONS S NIL))) + (SPADCALL |u| |factor|))))))) + +;P2Dmp(u, source is [., S], target is [., y, T]) == +; u = '_$fromCoerceable_$ => +; -- might be able to say yes +; canCoerce(source,T) +; u is [ =0,:c] => -- polynomial is a constant +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; univariate := getFunctionFromDomain('univariate, +; source,[source,$Symbol]) +; plus := getFunctionFromDomain("+",target,[target,target]) +; monom := getFunctionFromDomain('monomial,target, +; [target,['OrderedVariableList,y],$NonNegativeInteger]) +; P2DmpAux(u,source,S,target,copy y,y,T,univariate,plus,monom) + +(DEFUN |P2Dmp| (|u| |source| |target|) + (PROG (|y| T$ S |c| |u'| |univariate| |plus| |monom|) + (RETURN + (PROGN + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |univariate| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| (CONS |source| (CONS |$Symbol| NIL)))) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |monom| + (|getFunctionFromDomain| + (QUOTE |monomial|) + |target| + (CONS + |target| + (CONS + (CONS (QUOTE |OrderedVariableList|) (CONS |y| NIL)) + (CONS |$NonNegativeInteger| NIL))))) + (|P2DmpAux| |u| |source| S |target| (COPY |y|) + |y| T$ |univariate| |plus| |monom|))))))) + +;P2Expr(u, source is [.,S], target is [., T]) == +; u = '_$fromCoerceable_$ => +; canCoerce(S, T) +; S = T => coercionFailure() +; newS := ['Polynomial, T] +; val := coerceInt(objNewWrap(u, source), newS) +; null val => coercionFailure() +; val := coerceInt(val, target) +; null val => coercionFailure() +; objValUnwrap val + +(DEFUN |P2Expr| (|u| |source| |target|) + (PROG (T$ S |newS| |val|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((BOOT-EQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |newS| (CONS (QUOTE |Polynomial|) (CONS T$ NIL))) + (SPADLET |val| (|coerceInt| (|objNewWrap| |u| |source|) |newS|)) + (COND + ((NULL |val|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |val| (|coerceInt| |val| |target|)) + (COND + ((NULL |val|) (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |val|))))))))))) + +;P2DmpAux(u,source,S,target,varlist,vars,T,univariate,plus,monom) == +; u is [ =0,:c] => -- polynomial is a constant +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; -- if no variables left, try to go to underdomain of target (T) +; null vars => +; (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() +; -- if successful, embed +; (u' := coerceByFunction(u',target)) or coercionFailure() +; objValUnwrap(u') +; -- there are variables, so get them out of u +; [x,:vars] := vars +; sup := SPADCALL(u,x,univariate) -- this is a SUP P S +; null sup => -- zero? unlikely. +; domainZero(target) +; -- degree 0 polynomial? (variable did not occur) +; null(rest(sup)) and first(sup) is [ =0,:c] => +; -- call again, but with one less var +; P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom) +; var := position1(x,varlist) +; u' := domainZero(target) +; for [e,:c] in sup repeat +; u'' := SPADCALL( +; P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom), +; var,e,monom) +; u' := SPADCALL(u',u'',plus) +; u' + +(DEFUN |P2DmpAux| (|u| |source| S |target| |varlist| |vars| T$ |univariate| + |plus| |monom|) + (PROG (|LETTMP#1| |x| |sup| |ISTMP#1| |var| |e| |c| |u''| |u'|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((NULL |vars|) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (OR + (SPADLET |u'| (|coerceByFunction| |u'| |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |LETTMP#1| |vars|) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |vars| (CDR |LETTMP#1|)) + (SPADLET |sup| (SPADCALL |u| |x| |univariate|)) + (COND + ((NULL |sup|) (|domainZero| |target|)) + ((AND + (NULL (CDR |sup|)) + (PROGN + (SPADLET |ISTMP#1| (CAR |sup|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) 0) + (PROGN (SPADLET |c| (QCDR |ISTMP#1|)) (QUOTE T))))) + (|P2DmpAux| |c| |source| S |target| |varlist| |vars| T$ + |univariate| |plus| |monom|)) + ((QUOTE T) + (SPADLET |var| (|position1| |x| |varlist|)) + (SPADLET |u'| (|domainZero| |target|)) + (DO ((#0=#:G169021 |sup| (CDR #0#)) (#1=#:G169010 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |u''| + (SPADCALL + (|P2DmpAux| |c| |source| S |target| |varlist| |vars| T$ + |univariate| |plus| |monom|) + |var| + |e| + |monom|)) + (SPADLET |u'| (SPADCALL |u'| |u''| |plus|)))))) + |u'|)))))))) + +;P2Mp(u, source is [., S], target is [., y, T]) == +; u = '_$fromCoerceable_$ => +; -- might be able to say yes +; canCoerce(source,T) +; univariate := getFunctionFromDomain('univariate, +; source,[source,$Symbol]) +; P2MpAux(u,source,S,target,copy y,y,T,univariate) + +(DEFUN |P2Mp| (|u| |source| |target|) + (PROG (|y| T$ S |univariate|) + (RETURN + (PROGN + (SPADLET |y| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((QUOTE T) + (SPADLET |univariate| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| + (CONS |source| (CONS |$Symbol| NIL)))) + (|P2MpAux| |u| |source| S |target| (COPY |y|) |y| T$ |univariate|))))))) + +;P2MpAux(u,source,S,target,varlist,vars,T,univariate) == +; u is [ =0,:c] => -- polynomial is a constant +; (u' := coerceInt(objNewWrap(c,S),target)) or +; coercionFailure() +; objValUnwrap(u') +; -- if no variables left, try to go to underdomain of target (T) +; null vars => +; (u' := coerceInt(objNewWrap(u,source),T)) or +; coercionFailure() +; -- if successful, embed +; [ 0,:objValUnwrap(u')] +; -- there are variables, so get them out of u +; [x,:vars] := vars +; sup := SPADCALL(u,x,univariate) -- this is a SUP P S +; null sup => -- zero? unlikely. +; domainZero(target) +; -- degree 0 polynomial? (variable did not occur) +; null(rest(sup)) and first(sup) is [ =0,:c] => +; -- call again, but with one less var +; P2MpAux(c,source,S,target,varlist,vars,T,univariate) +; terms := [[e,:P2MpAux(c,source,S,target,varlist,vars,T,univariate)] for +; [e,:c] in sup] +; [1, position1(x,varlist), :terms] + +(DEFUN |P2MpAux| (|u| |source| S |target| |varlist| |vars| T$ |univariate|) + (PROG (|u'| |LETTMP#1| |x| |sup| |ISTMP#1| |e| |c| |terms|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((NULL |vars|) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (CONS 0 (|objValUnwrap| |u'|))) + ((QUOTE T) + (SPADLET |LETTMP#1| |vars|) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |vars| (CDR |LETTMP#1|)) + (SPADLET |sup| (SPADCALL |u| |x| |univariate|)) + (COND + ((NULL |sup|) (|domainZero| |target|)) + ((AND (NULL (CDR |sup|)) + (PROGN + (SPADLET |ISTMP#1| (CAR |sup|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) 0) + (PROGN (SPADLET |c| (QCDR |ISTMP#1|)) (QUOTE T))))) + (|P2MpAux| |c| |source| S |target| |varlist| |vars| T$ |univariate|)) + ((QUOTE T) + (SPADLET |terms| + (PROG (#0=#:G169095) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G169101 |sup| (CDR #1#)) (#2=#:G169085 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #2#)) + (SPADLET |c| (CDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS |e| + (|P2MpAux| |c| |source| S |target| |varlist| + |vars| T$ |univariate|)) + #0#)))))))) + (CONS 1 (CONS (|position1| |x| |varlist|) |terms|)))))))))) + +;varIsOnlyVarInPoly(u, var) == +; u is [ =1, v, :termlist] => +; v ^= var => nil +; and/[varIsOnlyVarInPoly(c,var) for [e,:c] in termlist] +; true + +(DEFUN |varIsOnlyVarInPoly| (|u| |var|) + (PROG (|ISTMP#1| |v| |termlist| |e| |c|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |termlist| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (COND + ((NEQUAL |v| |var|) NIL) + ((QUOTE T) + (PROG (#0=#:G169138) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G169145 NIL (NULL #0#)) + (#2=#:G169146 |termlist| (CDR #2#)) + (#3=#:G169132 NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #3#)) (SPADLET |c| (CDR #3#)) #3#) + NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# (AND #0# (|varIsOnlyVarInPoly| |c| |var|))))))))))) + ((QUOTE T) (QUOTE T))))))) + +;P2Up(u,source is [.,S],target is [.,x,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source,T) +; u is [ =0,:c] => +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; -- see if the target var is the polynomial vars +; varsFun := getFunctionFromDomain('variables,source,[source]) +; vars := SPADCALL(u,varsFun) +; not MEMBER(x,vars) => +; (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() +; [[0,:objValUnwrap(u')]] +; -- do a univariate to transform u to a UP(x,P S) and then coerce again +; UPP := ['UnivariatePolynomial,x,source] +; univariate := getFunctionFromDomain('univariate, +; source,[source,$Symbol]) +; upU := SPADCALL(u,x,univariate) -- we may assume this has type UPP +; (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() +; objValUnwrap(u') + +(DEFUN |P2Up| (|u| |source| |target|) + (PROG (|x| T$ S |c| |varsFun| |vars| UPP |univariate| |upU| |u'|) + (RETURN + (PROGN + (SPADLET |x| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) 0) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |varsFun| + (|getFunctionFromDomain| + (QUOTE |variables|) + |source| + (CONS |source| NIL))) + (SPADLET |vars| (SPADCALL |u| |varsFun|)) + (COND + ((NULL (|member| |x| |vars|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u'|)) NIL)) + ((QUOTE T) + (SPADLET UPP + (CONS + (QUOTE |UnivariatePolynomial|) + (CONS |x| (CONS |source| NIL)))) + (SPADLET |univariate| + (|getFunctionFromDomain| + (QUOTE |univariate|) + |source| + (CONS |source| (CONS |$Symbol| NIL)))) + (SPADLET |upU| (SPADCALL |u| |x| |univariate|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |upU| UPP) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|))))))))) + +;--% Fraction +;Qf2PF(u,source is [.,D],target) == +; u = '_$fromCoerceable_$ => canCoerce(D,target) +; [num,:den] := u +; num':= coerceInt(objNewWrap(num,D),target) or +; coercionFailure() +; num' := objValUnwrap num' +; den':= coerceInt(objNewWrap(den,D),target) or +; coercionFailure() +; den' := objValUnwrap den' +; equalZero(den', target) => throwKeyedMsg("S2IA0001",NIL) +; SPADCALL(num',den', getFunctionFromDomain("/",target,[target,target])) + +(DEFUN |Qf2PF| (|u| |source| |target|) + (PROG (D |num| |den| |num'| |den'|) + (RETURN + (PROGN + (SPADLET D (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| D |target|)) + ((QUOTE T) + (SPADLET |num| (CAR |u|)) + (SPADLET |den| (CDR |u|)) + (SPADLET |num'| + (OR (|coerceInt| (|objNewWrap| |num| D) |target|) (|coercionFailure|))) + (SPADLET |num'| (|objValUnwrap| |num'|)) + (SPADLET |den'| + (OR (|coerceInt| (|objNewWrap| |den| D) |target|) (|coercionFailure|))) + (SPADLET |den'| (|objValUnwrap| |den'|)) + (COND + ((|equalZero| |den'| |target|) (|throwKeyedMsg| (QUOTE S2IA0001) NIL)) + ((QUOTE T) + (SPADCALL |num'| |den'| + (|getFunctionFromDomain| (QUOTE /) |target| + (CONS |target| (CONS |target| NIL)))))))))))) + +;Qf2F(u,source is [.,D,:.],target) == +; D = $Integer => +; u = '_$fromCoerceable_$ => true +; Rn2F(u,source,target) +; u = '_$fromCoerceable_$ => canCoerce(D,target) +; [num,:den] := u +; [.,:num']:= coerceInt(objNewWrap(num,D),target) or +; coercionFailure() +; [.,:den']:= coerceInt(objNewWrap(den,D),target) or +; coercionFailure() +; (unwrap num') * 1.0 / (unwrap den') + +(DEFUN |Qf2F| (|u| |source| |target|) + (PROG (D |num| |den| |num'| |LETTMP#1| |den'|) + (RETURN + (PROGN + (SPADLET D (CADR |source|)) + (COND + ((BOOT-EQUAL D |$Integer|) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) (|Rn2F| |u| |source| |target|)))) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| D |target|)) + ((QUOTE T) + (SPADLET |num| (CAR |u|)) + (SPADLET |den| (CDR |u|)) + (SPADLET |LETTMP#1| + (OR (|coerceInt| (|objNewWrap| |num| D) |target|) (|coercionFailure|))) + (SPADLET |num'| (CDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|coerceInt| (|objNewWrap| |den| D) |target|) (|coercionFailure|))) + (SPADLET |den'| (CDR |LETTMP#1|)) + (QUOTIENT (TIMES (|unwrap| |num'|) 1.0) (|unwrap| |den'|)))))))) + +;Rn2F(rnum, source, target) == +; float(CAR(rnum)/CDR(rnum)) + +(DEFUN |Rn2F| (|rnum| |source| |target|) + (|float| (QUOTIENT (CAR |rnum|) (CDR |rnum|)))) + +;-- next function is needed in RN algebra code +;--Rn2F([a,:b],source,target) == +;-- al:=if LINTP a then QLENGTHCODE a else 4 +;-- bl:=if LINTP b then QLENGTHCODE b else 4 +;-- MAX(al,bl) < 36 => FLOAT a / FLOAT b +;-- sl:=0 +;-- if al>32 then +;-- sl:=35*(al-32)/4 +;-- a:=a/2**sl +;-- if bl>32 then +;-- sbl:=35*(bl-32)/4 +;-- b:=b/2**sbl +;-- sl:=sl-sbl +;-- ans:=FLOAT a /FLOAT b +;-- sl=0 => ans +;-- ans*2**sl +;Qf2domain(u,source is [.,D],target) == +; -- tests whether it is an element of the underlying domain +; useUnder := (ut := underDomainOf target) and canCoerce(source,ut) +; u = '_$fromCoerceable_$ => useUnder +; not (containsPolynomial(D) and containsPolynomial(target)) and +; useUnder => coercionFailure() -- let other mechanism handle it +; [num, :den] := u +; (num' := coerceInt(objNewWrap(num,D),target)) or coercionFailure() +; num' := objValUnwrap(num') +; equalOne(den,D) => num' +; (target is [.,[=$QuotientField,T]]) or +; (target is [.,.,[=$QuotientField,T]]) => +; (den' := coerceInt(objNewWrap(den,D),T)) or coercionFailure() +; den' := [domainOne(T),:objValUnwrap(den')] +; timesfunc:= getFunctionFromDomain('_*,target, +; [[$QuotientField,T],target]) +; SPADCALL(den',num',timesfunc) +; coercionFailure() + +(DEFUN |Qf2domain| (|u| |source| |target|) + (PROG (D |ut| |useUnder| |num| |den| |num'| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| T$ |den'| |timesfunc|) + (RETURN + (PROGN + (SPADLET D (CADR |source|)) + (SPADLET |useUnder| + (AND + (SPADLET |ut| (|underDomainOf| |target|)) + (|canCoerce| |source| |ut|))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) |useUnder|) + ((AND + (NULL (AND (|containsPolynomial| D) (|containsPolynomial| |target|))) + |useUnder|) + (|coercionFailure|)) + ((QUOTE T) + (SPADLET |num| (CAR |u|)) + (SPADLET |den| (CDR |u|)) + (OR + (SPADLET |num'| (|coerceInt| (|objNewWrap| |num| D) |target|)) + (|coercionFailure|)) + (SPADLET |num'| (|objValUnwrap| |num'|)) + (COND + ((|equalOne| |den| D) |num'|) + ((OR + (AND + (PAIRP |target|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQUAL (QCAR |ISTMP#2|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET T$ (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (AND + (PAIRP |target|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQUAL (QCAR |ISTMP#3|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN (SPADLET T$ (QCAR |ISTMP#4|)) (QUOTE T)))))))))))) + (OR + (SPADLET |den'| (|coerceInt| (|objNewWrap| |den| D) T$)) + (|coercionFailure|)) + (SPADLET |den'| (CONS (|domainOne| T$) (|objValUnwrap| |den'|))) + (SPADLET |timesfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS (CONS |$QuotientField| (CONS T$ NIL)) (CONS |target| NIL)))) + (SPADCALL |den'| |num'| |timesfunc|)) + ((QUOTE T) (|coercionFailure|))))))))) + +;Qf2EF(u,[.,S],target) == +; u = '_$fromCoerceable_$ => canCoerce(S,target) +; [num,:den] := u +; (num' := coerceInt(objNewWrap(num,S),target)) or +; coercionFailure() +; (den' := coerceInt(objNewWrap(den,S),target)) or +; coercionFailure() +; divfun := getFunctionFromDomain("/",target,[target,target]) +; SPADCALL(objValUnwrap(num'),objValUnwrap(den'),divfun) + +(DEFUN |Qf2EF| (|u| #0=#:G169372 |target|) + (PROG (S |num| |den| |num'| |den'| |divfun|) + (RETURN + (PROGN + (SPADLET S (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((QUOTE T) + (SPADLET |num| (CAR |u|)) + (SPADLET |den| (CDR |u|)) + (OR + (SPADLET |num'| (|coerceInt| (|objNewWrap| |num| S) |target|)) + (|coercionFailure|)) + (OR + (SPADLET |den'| (|coerceInt| (|objNewWrap| |den| S) |target|)) + (|coercionFailure|)) + (SPADLET |divfun| + (|getFunctionFromDomain| + (QUOTE /) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL + (|objValUnwrap| |num'|) + (|objValUnwrap| |den'|) + |divfun|))))))) + +;Qf2Qf(u0,[.,S],target is [.,T]) == +; u0 = '_$fromCoerceable_$ => +; S = ['Polynomial, [$QuotientField, $Integer]] and +; T = '(Polynomial (Integer)) => true +; canCoerce(S,T) +; [a,:b] := u0 +; S = ['Polynomial, [$QuotientField, $Integer]] and +; T = '(Polynomial (Integer)) => +; (a' := coerceInt(objNewWrap(a,S),target)) => +; (b' := coerceInt(objNewWrap(b,S),target)) => +; divfunc:= getFunctionFromDomain('_/,target,[target,target]) +; SPADCALL(objValUnwrap(a'),objValUnwrap(b'),divfunc) +; coercionFailure() +; coercionFailure() +; (a' := coerceInt(objNewWrap(a,S),T)) => +; (b' := coerceInt(objNewWrap(b,S),T)) => +; [objValUnwrap(a'),:objValUnwrap(b')] +; coercionFailure() +; coercionFailure() + +(DEFUN |Qf2Qf| (|u0| #0=#:G169409 |target|) + (PROG (S T$ |a| |b| |divfunc| |a'| |b'|) + (RETURN + (PROGN + (SPADLET S (CADR #0#)) + (SPADLET T$ (CADR |target|)) + (COND + ((BOOT-EQUAL |u0| (QUOTE |$fromCoerceable$|)) + (COND + ((AND + (BOOT-EQUAL S + (CONS + (QUOTE |Polynomial|) + (CONS (CONS |$QuotientField| (CONS |$Integer| NIL)) NIL))) + (BOOT-EQUAL T$ (QUOTE (|Polynomial| (|Integer|))))) + (QUOTE T)) + ((QUOTE T) (|canCoerce| S T$)))) + ((QUOTE T) + (SPADLET |a| (CAR |u0|)) + (SPADLET |b| (CDR |u0|)) + (COND + ((AND + (BOOT-EQUAL S + (CONS + (QUOTE |Polynomial|) + (CONS (CONS |$QuotientField| (CONS |$Integer| NIL)) NIL))) + (BOOT-EQUAL T$ (QUOTE (|Polynomial| (|Integer|))))) + (COND + ((SPADLET |a'| (|coerceInt| (|objNewWrap| |a| S) |target|)) + (COND + ((SPADLET |b'| (|coerceInt| (|objNewWrap| |b| S) |target|)) + (SPADLET |divfunc| + (|getFunctionFromDomain| + (QUOTE /) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL (|objValUnwrap| |a'|) (|objValUnwrap| |b'|) |divfunc|)) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) (|coercionFailure|)))) + ((SPADLET |a'| (|coerceInt| (|objNewWrap| |a| S) T$)) + (COND + ((SPADLET |b'| (|coerceInt| (|objNewWrap| |b| S) T$)) + (CONS (|objValUnwrap| |a'|) (|objValUnwrap| |b'|))) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) (|coercionFailure|))))))))) + +;-- partOf(x,i) == +;-- VECP x => x.i +;-- i=0 => first x +;-- i=1 => rest x +;-- systemError '"partOf" +;--% RectangularMatrix +;Rm2L(x,[.,.,.,R],target) == M2L(x,['Matrix,R],target) + +(DEFUN |Rm2L| (|x| #0=#:G169434 |target|) + (PROG (R) + (RETURN + (PROGN + (SPADLET R (CADDDR #0#)) + (M2L |x| (CONS (QUOTE |Matrix|) (CONS R NIL)) |target|))))) + +;Rm2M(x,[.,.,.,R],target is [.,S]) == M2M(x,[nil,R],target) + +(DEFUN |Rm2M| (|x| #0=#:G169451 |target|) + (PROG (R S) + (RETURN + (PROGN + (SPADLET R (CADDDR #0#)) + (SPADLET S (CADR |target|)) + (M2M |x| (CONS NIL (CONS R NIL)) |target|))))) + +;Rm2Sm(x,[.,n,m,S],[.,p,R]) == +; x = '_$fromCoerceable_$ => n=m and m=p and canCoerce(S,R) +; n=m and m=p => +; M2M(x,[nil,S],[nil,R]) +; coercionFailure() + +(DEFUN |Rm2Sm| (|x| #0=#:G169467 #1=#:G169478) + (PROG (|p| R |n| |m| S) + (RETURN + (PROGN + (SPADLET |p| (CADR #1#)) + (SPADLET R (CADDR #1#)) + (SPADLET |n| (CADR #0#)) + (SPADLET |m| (CADDR #0#)) + (SPADLET S (CADDDR #0#)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) + (AND (BOOT-EQUAL |n| |m|) (BOOT-EQUAL |m| |p|) (|canCoerce| S R))) + ((AND (BOOT-EQUAL |n| |m|) (BOOT-EQUAL |m| |p|)) + (M2M |x| (CONS NIL (CONS S NIL)) (CONS NIL (CONS R NIL)))) + ((QUOTE T) (|coercionFailure|))))))) + +;Rm2V(x,[.,.,.,R],target) == M2V(x,['Matrix,R],target) + +(DEFUN |Rm2V| (|x| #0=#:G169500 |target|) + (PROG (R) + (RETURN + (PROGN + (SPADLET R (CADDDR #0#)) + (M2V |x| (CONS (QUOTE |Matrix|) (CONS R NIL)) |target|))))) + +;--% Script +;Scr2Scr(u, source is [.,S], target is [.,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S,T) +; null (v := coerceInt(objNewWrap(CDR u,S),T)) => +; coercionFailure() +; [CAR u, :objValUnwrap(v)] + +(DEFUN |Scr2Scr| (|u| |source| |target|) + (PROG (T$ S |v|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((NULL (SPADLET |v| (|coerceInt| (|objNewWrap| (CDR |u|) S) T$))) + (|coercionFailure|)) + ((QUOTE T) (CONS (CAR |u|) (|objValUnwrap| |v|)))))))) + +;--% SparseUnivariatePolynomialnimial +;SUP2Up(u,source is [.,S],target is [.,x,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) +; null u => u +; S = T => u +; -- try to go underneath first +; null (u' := coerceInt(objNewWrap(u,source),T)) => +; -- must be careful in case any of the coeffs come back 0 +; u' := NIL +; zero := getConstantFromDomain('(Zero),T) +; for [e,:c] in u repeat +; c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or +; coercionFailure()) +; c' = zero => 'iterate +; u' := [[e,:c'],:u'] +; nreverse u' +; [[0,:objValUnwrap u']] + +(DEFUN |SUP2Up| (|u| |source| |target|) + (PROG (|x| T$ S |zero| |e| |c| |c'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |x| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|canCoerce| |source| T$) (|canCoerce| S T$))) + ((NULL |u|) |u|) + ((BOOT-EQUAL S T$) |u|) + ((NULL (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$))) + (SPADLET |u'| NIL) + (SPADLET |zero| (|getConstantFromDomain| (QUOTE (|Zero|)) T$)) + (DO ((#0=#:G169569 |u| (CDR #0#)) (#1=#:G169534 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |c'| + (|objValUnwrap| + (OR (|coerceInt| (|objNewWrap| |c| S) T$) (|coercionFailure|)))) + (COND + ((BOOT-EQUAL |c'| |zero|) (QUOTE |iterate|)) + ((QUOTE T) (SPADLET |u'| (CONS (CONS |e| |c'|) |u'|)))))))) + (NREVERSE |u'|)) + ((QUOTE T) (CONS (CONS 0 (|objValUnwrap| |u'|)) NIL)))))))) + +;--% SquareMatrix +;Sm2L(x,[.,.,R],target) == M2L(x,['Matrix,R],target) + +(DEFUN |Sm2L| (|x| #0=#:G169589 |target|) + (PROG (R) + (RETURN + (PROGN + (SPADLET R (CADDR #0#)) + (M2L |x| (CONS (QUOTE |Matrix|) (CONS R NIL)) |target|))))) + +;Sm2M(x,[.,n,R],target is [.,S]) == M2M(x,[nil,R],target) + +(DEFUN |Sm2M| (|x| #0=#:G169606 |target|) + (PROG (|n| R S) + (RETURN + (PROGN + (SPADLET |n| (CADR #0#)) + (SPADLET R (CADDR #0#)) + (SPADLET S (CADR |target|)) + (M2M |x| (CONS NIL (CONS R NIL)) |target|))))) + +;Sm2PolyType(u,source is [sm,n,S], target is [pol,vl,T]) == +; -- only really handles cases like: +; -- SM[2] P I -> P[x,y] SM[2] P I +; -- works for UP, MP, DMP and NDMP +; u = '_$fromCoerceable_$ => canCoerce(source,T) +; -- first want to check case S is Polynomial +; S is ['Polynomial,S'] => +; -- check to see if variable occurs in any of the terms +; if ATOM vl +; then vl' := [vl] +; else vl' := vl +; novars := true +; for i in 0..(n-1) while novars repeat +; for j in 0..(n-1) while novars repeat +; varsUsed := varsInPoly u.i.j +; or/[MEMBER(x,varsUsed) for x in vl'] => novars := nil +; novars => coercionFailure() +; source' := [sm,n,[pol,vl,S]] +; null (u' := coerceInt(objNewWrap(u,source),source')) => +; coercionFailure() +; null (u' := coerceInt(u',target)) => +; coercionFailure() +; objValUnwrap(u') +; -- let other cases be handled by standard machinery +; coercionFailure() + +(DEFUN |Sm2PolyType| (|u| |source| |target|) + (PROG (|pol| |vl| T$ |sm| |n| S |ISTMP#1| |S'| |vl'| |varsUsed| + |novars| |source'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET |pol| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |sm| (CAR |source|)) + (SPADLET |n| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| T$)) + ((AND (PAIRP S) + (EQ (QCAR S) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR S)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |S'| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((ATOM |vl|) (SPADLET |vl'| (CONS |vl| NIL))) + ((QUOTE T) (SPADLET |vl'| |vl|))) + (SPADLET |novars| (QUOTE T)) + (DO ((#0=#:G169670 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) + ((OR (QSGREATERP |i| #0#) (NULL |novars|)) NIL) + (SEQ + (EXIT + (DO ((#1=#:G169681 (SPADDIFFERENCE |n| 1)) (|j| 0 (QSADD1 |j|))) + ((OR (QSGREATERP |j| #1#) (NULL |novars|)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |varsUsed| (|varsInPoly| (ELT (ELT |u| |i|) |j|))) + (COND + ((PROG (#2=#:G169686) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G169692 NIL #2#) + (#4=#:G169693 |vl'| (CDR #4#)) + (|x| NIL)) + ((OR #3# (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) + #2#) + (SEQ + (EXIT + (SETQ #2# (OR #2# (|member| |x| |varsUsed|)))))))) + (SPADLET |novars| NIL)))))))))) + (COND + (|novars| (|coercionFailure|)) + ((QUOTE T) + (SPADLET |source'| + (CONS |sm| + (CONS |n| (CONS (CONS |pol| (CONS |vl| (CONS S NIL))) NIL)))) + (COND + ((NULL + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) |source'|))) + (|coercionFailure|)) + ((NULL (SPADLET |u'| (|coerceInt| |u'| |target|))) + (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |u'|)))))) + ((QUOTE T) (|coercionFailure|)))))))) + +;Sm2Rm(x,[.,n,R],[.,p,q,S]) == +; x = '_$fromCoerceable_$ => p=q and p=n and canCoerce(R,S) +; p=q and p=n => +; M2M(x,[nil,R],[nil,S]) +; coercionFailure() + +(DEFUN |Sm2Rm| (|x| #0=#:G169721 #1=#:G169730) + (PROG (|p| |q| S |n| R) + (RETURN + (PROGN + (SPADLET |p| (CADR #1#)) + (SPADLET |q| (CADDR #1#)) + (SPADLET S (CADDDR #1#)) + (SPADLET |n| (CADR #0#)) + (SPADLET R (CADDR #0#)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) + (AND (BOOT-EQUAL |p| |q|) (BOOT-EQUAL |p| |n|) (|canCoerce| R S))) + ((AND (BOOT-EQUAL |p| |q|) (BOOT-EQUAL |p| |n|)) + (M2M |x| (CONS NIL (CONS R NIL)) (CONS NIL (CONS S NIL)))) + ((QUOTE T) (|coercionFailure|))))))) + +;Sm2V(x,[.,.,R],target) == M2V(x,['Matrix,R],target) + +(DEFUN |Sm2V| (|x| #0=#:G169753 |target|) + (PROG (R) + (RETURN + (PROGN + (SPADLET R (CADDR #0#)) + (M2V |x| (CONS (QUOTE |Matrix|) (CONS R NIL)) |target|))))) + +;--% Symbol +;Sy2OV(u,source,target is [.,vl]) == +; u = '_$fromCoerceable_$ => nil +; position1(u,vl) + +(DEFUN |Sy2OV| (|u| |source| |target|) + (PROG (|vl|) + (RETURN + (PROGN + (SPADLET |vl| (CADR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) (|position1| |u| |vl|))))))) + +;Sy2Dmp(u,source,target is [dmp,vl,S]) == +; u = '_$fromCoerceable_$ => canCoerce(source,S) +; len:= #vl +; -1^=(n:= position(u,vl)) => +; u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] +; objValUnwrap(coerceInt(objNew(u,[dmp,vl,$Integer]),target)) +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[Zeros len,:objValUnwrap u]] + +(DEFUN |Sy2Dmp| (|u| |source| |target|) + (PROG (|dmp| |vl| S |len| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |dmp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| S)) + ((QUOTE T) + (SPADLET |len| (|#| |vl|)) + (COND + ((NEQUAL (SPADDIFFERENCE 1) (SPADLET |n| (|position| |u| |vl|))) + (SPADLET |u| + (|wrap| + (LIST + (CONS + (LIST2VEC + (PROG (#0=#:G169792) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G169797 (SPADDIFFERENCE |len| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND + ((BOOT-EQUAL |n| |i|) 1) + ((QUOTE T) 0)) #0#)))))))) + 1)))) + (|objValUnwrap| + (|coerceInt| + (|objNew| |u| (CONS |dmp| (CONS |vl| (CONS |$Integer| NIL)))) + |target|))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS (|Zeros| |len|) (|objValUnwrap| |u|)) NIL)))))))))) + +;Sy2Mp(u,source,target is [mp,vl,S]) == +; u = '_$fromCoerceable_$ => canCoerce(source,S) +; (n:= position1(u,vl)) ^= 0 => +; [1,n,[1,0,:domainOne(S)]] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [0,:objValUnwrap(u)] + +(DEFUN |Sy2Mp| (|u| |source| |target|) + (PROG (|mp| |vl| S |n|) + (RETURN + (PROGN + (SPADLET |mp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| S)) + ((NEQUAL (SPADLET |n| (|position1| |u| |vl|)) 0) + (CONS 1 (CONS |n| (CONS (CONS 1 (CONS 0 (|domainOne| S))) NIL)))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS 0 (|objValUnwrap| |u|)))))))) + +;Sy2NDmp(u,source,target is [ndmp,vl,S]) == +; u = '_$fromCoerceable_$ => canCoerce(source,S) +; len:= #vl +; -1^=(n:= position(u,vl)) => +; u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] +; objValUnwrap(coerceInt(objNew(u,[ndmp,vl,$Integer]),target)) +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[Zeros len,:objValUnwrap(u)]] + +(DEFUN |Sy2NDmp| (|u| |source| |target|) + (PROG (|ndmp| |vl| S |len| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |ndmp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| S)) + ((QUOTE T) + (SPADLET |len| (|#| |vl|)) + (COND + ((NEQUAL (SPADDIFFERENCE 1) (SPADLET |n| (|position| |u| |vl|))) + (SPADLET |u| + (|wrap| + (LIST + (CONS + (LIST2VEC + (PROG (#0=#:G169848) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G169853 (SPADDIFFERENCE |len| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND + ((BOOT-EQUAL |n| |i|) 1) + ((QUOTE T) 0)) #0#)))))))) + 1)))) + (|objValUnwrap| + (|coerceInt| + (|objNew| |u| (CONS |ndmp| (CONS |vl| (CONS |$Integer| NIL)))) + |target|))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS (|Zeros| |len|) (|objValUnwrap| |u|)) NIL)))))))))) + +;Sy2P(u,source,target is [poly,S]) == +; u = '_$fromCoerceable_$ => true +; -- first try to get it into an underdomain +; if (S ^= $Integer) then +; u' := coerceInt(objNewWrap(u,source),S) +; if u' then return [0,:objValUnwrap(u')] +; -- if that failed, return it as a polynomial variable +; [1,u,[1,0,:domainOne(S)]] + +(DEFUN |Sy2P| (|u| |source| |target|) + (PROG (|poly| S |u'|) + (RETURN + (PROGN + (SPADLET |poly| (CAR |target|)) + (SPADLET S (CADR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) + (COND + ((NEQUAL S |$Integer|) + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (COND (|u'| (RETURN (CONS 0 (|objValUnwrap| |u'|)))) ((QUOTE T) NIL)))) + (CONS 1 (CONS |u| (CONS (CONS 1 (CONS 0 (|domainOne| S))) NIL))))))))) + +;Sy2Up(u,source,target is [up,x,S]) == +; u = '_$fromCoerceable_$ => canCoerce(source,S) +; u=x => [[1,:domainOne(S)]] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[0,:objValUnwrap u]] + +(DEFUN |Sy2Up| (|u| |source| |target|) + (PROG (|up| |x| S) + (RETURN + (PROGN + (SPADLET |up| (CAR |target|)) + (SPADLET |x| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| S)) + ((BOOT-EQUAL |u| |x|) (CONS (CONS 1 (|domainOne| S)) NIL)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u|)) NIL))))))) + +;Sy2Var(u,source,target is [.,x]) == +; u = '_$fromCoerceable_$ => NIL +; u=x => u +; coercionFailure() + +(DEFUN |Sy2Var| (|u| |source| |target|) + (PROG (|x|) + (RETURN + (PROGN + (SPADLET |x| (CADR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((BOOT-EQUAL |u| |x|) |u|) + ((QUOTE T) (|coercionFailure|))))))) + +;--% Univariate Polynomial +;Up2Dmp(u,source is ['UnivariatePolynomial,var,S], +; target is ['DistributedMultivariatePolynomial,vl,T]) == +; -- var must be a member of vl, or u is a constant +; u = '_$fromCoerceable_$ => MEMBER(var,vl) and canCoerce(S,target) +; null u => domainZero(target) +; u is [[e,:c]] and e=0 => +; z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) +; coercionFailure() +; MEMBER(var,vl) => +; x:= domainZero(target) +; one:= domainOne(T) +; plusfunc:= getFunctionFromDomain('_+,target,[target,target]) +; multfunc:= getFunctionFromDomain('_*,target,[target,target]) +; n:= #vl ; p:= POSN1(var,vl) +; l1:= not (p=0) and [0 for m in 1..p] +; l2:= not (p=n-1) and [0 for m in p..n-2] +; for [e,:c] in u until not z repeat +; z:= coerceInt(objNewWrap(c,S),target) => +; y:= SPADCALL(objValUnwrap(z), +; [[LIST2VEC [:l1,e,:l2],:one]],multfunc) +; x:= SPADCALL(x,y,plusfunc) +; z => x +; coercionFailure() +; coercionFailure() + +(DEFUN |Up2Dmp| (|u| |source| |target|) + (PROG (|vl| T$ |var| S |ISTMP#1| |one| |plusfunc| |multfunc| |n| |p| |l1| + |l2| |e| |c| |z| |y| |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |vl| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |var| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (AND (|member| |var| |vl|) (|canCoerce| S |target|))) + ((NULL |u|) (|domainZero| |target|)) + ((AND (PAIRP |u|) + (EQ (QCDR |u|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (EQL |e| 0)) + (COND + ((SPADLET |z| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |z|)) + ((QUOTE T) (|coercionFailure|)))) + ((|member| |var| |vl|) + (SPADLET |x| (|domainZero| |target|)) + (SPADLET |one| (|domainOne| T$)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |n| (|#| |vl|)) + (SPADLET |p| (POSN1 |var| |vl|)) + (SPADLET |l1| + (AND + (NULL (EQL |p| 0)) + (PROG (#0=#:G169969) + (SPADLET #0# NIL) + (RETURN + (DO ((|m| 1 (QSADD1 |m|))) + ((QSGREATERP |m| |p|) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS 0 #0#))))))))) + (SPADLET |l2| + (AND + (NULL (BOOT-EQUAL |p| (SPADDIFFERENCE |n| 1))) + (PROG (#1=#:G169981) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G169986 (SPADDIFFERENCE |n| 2)) (|m| |p| (+ |m| 1))) + ((> |m| #2#) (NREVERSE0 #1#)) + (SEQ (EXIT (SETQ #1# (CONS 0 #1#))))))))) + (SEQ + (DO ((#3=#:G169997 |u| (CDR #3#)) + (#4=#:G169923 NIL) + (#5=#:G169998 NIL (NULL |z|))) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #4#)) (SPADLET |c| (CDR #4#)) #4#) + NIL) + #5#) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |z| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (EXIT + (PROGN + (SPADLET |y| + (SPADCALL + (|objValUnwrap| |z|) + (CONS + (CONS (LIST2VEC (APPEND |l1| (CONS |e| |l2|))) |one|) + NIL) + |multfunc|)) + (SPADLET |x| (SPADCALL |x| |y| |plusfunc|))))))))) + (COND (|z| (EXIT |x|))) (|coercionFailure|))) + ((QUOTE T) (|coercionFailure|)))))))) + +;Up2Expr(u,source is [up,var,S], target is [Expr,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S, target) +; null u => domainZero(target) +; u is [[e,:c]] and e=0 => +; (z := coerceInt(objNewWrap(c, S), target)) => objValUnwrap(z) +; coercionFailure() +; sym := objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) +; plus := getFunctionFromDomain("+", target, [target, target]) +; mult := getFunctionFromDomain("*", target, [target, target]) +; expn := getFunctionFromDomain("**", target, [target, $Integer]) +; -- coerce via Horner's rule +; [e1, :c1] := first u +; if not (S = target) then +; not (c1 := coerceInt(objNewWrap(c1, S), target)) => coercionFailure() +; c1 := objValUnwrap(c1) +; for [e2, :c2] in rest u repeat +; coef := +; e1 - e2 = 1 => sym +; SPADCALL(sym, e1-e2, expn) +; if not (S = target) then +; not (c2 := coerceInt(objNewWrap(c2, S), target)) => +; coercionFailure() +; c2 := objValUnwrap(c2) +; coef := SPADCALL(SPADCALL(c1, coef, mult), c2, plus) +; e1 := e2 +; c1 := coef +; e1 = 0 => c1 +; e1 = 1 => SPADCALL(sym, c1, mult) +; SPADCALL(SPADCALL(sym, e1, expn), c1, mult) + +(DEFUN |Up2Expr| (|u| |source| |target|) + (PROG (|Expr| T$ |up| |var| S |ISTMP#1| |e| |c| |z| |sym| |plus| |mult| + |expn| |LETTMP#1| |e2| |c2| |coef| |e1| |c1|) + (RETURN + (SEQ + (PROGN + (SPADLET |Expr| (CAR |target|)) + (SPADLET T$ (CADR |target|)) + (SPADLET |up| (CAR |source|)) + (SPADLET |var| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((NULL |u|) (|domainZero| |target|)) + ((AND (PAIRP |u|) + (EQ (QCDR |u|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (EQL |e| 0)) + (COND + ((SPADLET |z| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |z|)) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) + (SPADLET |sym| + (|objValUnwrap| (|coerceInt| (|objNewWrap| |var| |$Symbol|) |target|))) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |mult| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |expn| + (|getFunctionFromDomain| + (QUOTE **) + |target| + (CONS |target| (CONS |$Integer| NIL)))) + (SPADLET |LETTMP#1| (CAR |u|)) + (SPADLET |e1| (CAR |LETTMP#1|)) + (SPADLET |c1| (CDR |LETTMP#1|)) + (COND + ((NULL (BOOT-EQUAL S |target|)) + (COND + ((NULL (SPADLET |c1| (|coerceInt| (|objNewWrap| |c1| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) (SPADLET |c1| (|objValUnwrap| |c1|)))))) + (DO ((#0=#:G170113 (CDR |u|) (CDR #0#)) (#1=#:G170052 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e2| (CAR #1#)) + (SPADLET |c2| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |coef| + (COND + ((EQL (SPADDIFFERENCE |e1| |e2|) 1) |sym|) + ((QUOTE T) (SPADCALL |sym| (SPADDIFFERENCE |e1| |e2|) |expn|)))) + (COND + ((NULL (BOOT-EQUAL S |target|)) + (COND + ((NULL + (SPADLET |c2| (|coerceInt| (|objNewWrap| |c2| S) |target|))) + (|coercionFailure|)) + ((QUOTE T) (SPADLET |c2| (|objValUnwrap| |c2|)))))) + (SPADLET |coef| + (SPADCALL (SPADCALL |c1| |coef| |mult|) |c2| |plus|)) + (SPADLET |e1| |e2|) (SPADLET |c1| |coef|))))) + (COND + ((EQL |e1| 0) |c1|) + ((EQL |e1| 1) (SPADCALL |sym| |c1| |mult|)) + ((QUOTE T) + (SPADCALL (SPADCALL |sym| |e1| |expn|) |c1| |mult|)))))))))) + +;Up2FR(u,S is [.,x,R],target is [.,T]) == +; u = '_$fromCoerceable_$ => +; S ^= T => nil +; R in '((Integer) (Fraction (Integer))) => true +; nil +; S ^= T => coercionFailure() +; package := +; R = $Integer => ['UnivariateFactorize,S] +; R = $RationalNumber => package := ['RationalFactorize,S] +; coercionFailure() +; factor := getFunctionFromDomain('factor,package,[S]) +; SPADCALL(u,factor) + +(DEFUN |Up2FR| (|u| S |target|) + (PROG (T$ |x| R |package| |factor|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |x| (CADR S)) + (SPADLET R (CADDR S)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((NEQUAL S T$) NIL) + ((|member| R (QUOTE ((|Integer|) (|Fraction| (|Integer|))))) (QUOTE T)) + ((QUOTE T) NIL))) + ((NEQUAL S T$) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |package| + (COND + ((BOOT-EQUAL R |$Integer|) + (CONS (QUOTE |UnivariateFactorize|) (CONS S NIL))) + ((BOOT-EQUAL R |$RationalNumber|) + (SPADLET |package| (CONS (QUOTE |RationalFactorize|) (CONS S NIL)))) + ((QUOTE T) (|coercionFailure|)))) + (SPADLET |factor| + (|getFunctionFromDomain| (QUOTE |factor|) |package| (CONS S NIL))) + (SPADCALL |u| |factor|))))))) + +;Up2Mp(u,source is [.,x,S], target is [.,vl,T]) == +; u = '_$fromCoerceable_$ => +; MEMBER(x,vl) => canCoerce(S,T) +; canCoerce(source,T) +; null u => domainZero(target) +; null(rest(u)) and (first(u) is [e,:c]) and e=0 => +; x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) +; coercionFailure() +; null MEMBER(x,vl) => +; (x := coerceInt(objNewWrap(u,source),T)) or coercionFailure() +; [0,:objValUnwrap(x)] +; plus := getFunctionFromDomain('_+,target,[target,target]) +; monom := getFunctionFromDomain('monomial,target, +; [target,['OrderedVariableList,vl],$NonNegativeInteger]) +; sum := domainZero(target) +; pos := position1(x,vl) +; for [e,:c] in u repeat +; (p := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; mon := SPADCALL(objValUnwrap(p),pos,e,monom) +; sum := SPADCALL(sum,mon,plus) +; sum + +(DEFUN |Up2Mp| (|u| |source| |target|) + (PROG (|vl| T$ S |ISTMP#1| |x| |plus| |monom| |pos| |e| |c| |p| |mon| |sum|) + (RETURN + (SEQ + (PROGN + (SPADLET |vl| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((|member| |x| |vl|) (|canCoerce| S T$)) + ((QUOTE T) (|canCoerce| |source| T$)))) + ((NULL |u|) (|domainZero| |target|)) + ((AND (NULL (CDR |u|)) + (PROGN + (SPADLET |ISTMP#1| (CAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (EQL |e| 0)) + (COND + ((SPADLET |x| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |x|)) + ((QUOTE T) (|coercionFailure|)))) + ((NULL (|member| |x| |vl|)) + (OR + (SPADLET |x| (|coerceInt| (|objNewWrap| |u| |source|) T$)) + (|coercionFailure|)) + (CONS 0 (|objValUnwrap| |x|))) + ((QUOTE T) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |monom| + (|getFunctionFromDomain| + (QUOTE |monomial|) + |target| + (CONS + |target| + (CONS + (CONS (QUOTE |OrderedVariableList|) (CONS |vl| NIL)) + (CONS |$NonNegativeInteger| NIL))))) + (SPADLET |sum| (|domainZero| |target|)) + (SPADLET |pos| (|position1| |x| |vl|)) + (DO ((#0=#:G170239 |u| (CDR #0#)) (#1=#:G170191 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (OR + (SPADLET |p| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (SPADLET |mon| (SPADCALL (|objValUnwrap| |p|) |pos| |e| |monom|)) + (SPADLET |sum| (SPADCALL |sum| |mon| |plus|)))))) + |sum|))))))) + +;Up2P(u,source is [.,var,S],target is [.,T]) == +; u = '_$fromCoerceable_$ => canCoerce(S,target) +; null u => domainZero(target) +; u is [[e,:c]] and e=0 => +; x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) +; coercionFailure() +; pol:= domainZero(target) +; one:= domainOne(T) +; plusfunc := getFunctionFromDomain("+",target,[target,target]) +; multfunc := getFunctionFromDomain("*",target,[target,target]) +; for [e,:c] in u until not x repeat +; x:= coerceInt(objNewWrap(c,S),target) => +; term:= SPADCALL([1,var,[e,0,:one]],objValUnwrap(x),multfunc) +; pol:= SPADCALL(pol,term,plusfunc) +; coercionFailure() +; x => pol +; coercionFailure() + +(DEFUN |Up2P| (|u| |source| |target|) + (PROG (T$ |var| S |ISTMP#1| |one| |plusfunc| |multfunc| |e| |c| |x| + |term| |pol|) + (RETURN + (SEQ + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |var| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((NULL |u|) (|domainZero| |target|)) + ((AND (PAIRP |u|) + (EQ (QCDR |u|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (EQL |e| 0)) + (COND + ((SPADLET |x| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |x|)) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) + (SPADLET |pol| (|domainZero| |target|)) + (SPADLET |one| (|domainOne| T$)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (DO ((#0=#:G170322 |u| (CDR #0#)) + (#1=#:G170278 NIL) + (#2=#:G170323 NIL (NULL |x|))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |e| (CAR #1#)) + (SPADLET |c| (CDR #1#)) + #1#) + NIL) + #2#) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |x| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (SPADLET |term| + (SPADCALL + (CONS 1 (CONS |var| (CONS (CONS |e| (CONS 0 |one|)) NIL))) + (|objValUnwrap| |x|) + |multfunc|)) + (SPADLET |pol| (SPADCALL |pol| |term| |plusfunc|))) + ((QUOTE T) (|coercionFailure|)))))) + (COND + (|x| |pol|) + ((QUOTE T) (|coercionFailure|)))))))))) + +;Up2SUP(u,source is [.,x,S],target is [.,T]) == +; u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) +; null u => u +; S = T => u +; -- try to go underneath first +; null (u' := coerceInt(objNewWrap(u,source),T)) => +; u' := NIL +; zero := getConstantFromDomain('(Zero),T) +; for [e,:c] in u repeat +; c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or +; coercionFailure()) +; c' = zero => 'iterate +; u' := [[e,:c'],:u'] +; nreverse u' +; [[0,:objValUnwrap u']] + +(DEFUN |Up2SUP| (|u| |source| |target|) + (PROG (T$ |x| S |zero| |e| |c| |c'| |u'|) + (RETURN + (SEQ + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |x| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|canCoerce| |source| T$) (|canCoerce| S T$))) + ((NULL |u|) |u|) + ((BOOT-EQUAL S T$) |u|) + ((NULL (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) T$))) + (SPADLET |u'| NIL) + (SPADLET |zero| (|getConstantFromDomain| (QUOTE (|Zero|)) T$)) + (DO ((#0=#:G170387 |u| (CDR #0#)) (#1=#:G170351 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |c'| + (|objValUnwrap| + (OR (|coerceInt| (|objNewWrap| |c| S) T$) (|coercionFailure|)))) + (COND + ((BOOT-EQUAL |c'| |zero|) (QUOTE |iterate|)) + ((QUOTE T) (SPADLET |u'| (CONS (CONS |e| |c'|) |u'|)))))))) + (NREVERSE |u'|)) + ((QUOTE T) (CONS (CONS 0 (|objValUnwrap| |u'|)) NIL)))))))) + +;Up2Up(u,source is [.,v1,S], target is [.,v2,T]) == +; -- if v1 = v2 then this is handled by coerceIntByMap +; -- this only handles case where poly is a constant +; u = '_$fromCoerceable_$ => +; v1=v2 => canCoerce(S,T) +; canCoerce(source,T) +; null u => u +; u is [[e,:c]] and e=0 => +; x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) +; coercionFailure() +; coercionFailure() + +(DEFUN |Up2Up| (|u| |source| |target|) + (PROG (|v2| T$ |v1| S |ISTMP#1| |e| |c| |x|) + (RETURN + (PROGN + (SPADLET |v2| (CADR |target|)) + (SPADLET T$ (CADDR |target|)) + (SPADLET |v1| (CADR |source|)) + (SPADLET S (CADDR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((BOOT-EQUAL |v1| |v2|) (|canCoerce| S T$)) + ((QUOTE T) (|canCoerce| |source| T$)))) + ((NULL |u|) |u|) + ((AND (PAIRP |u|) + (EQ (QCDR |u|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |e| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (EQL |e| 0)) + (COND + ((SPADLET |x| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|objValUnwrap| |x|)) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) (|coercionFailure|))))))) + +;insertAlist(a,b,l) == +; null l => [[a,:b]] +; a = l.0.0 => (RPLAC(CDAR l,b);l) +; _?ORDER(l.0.0,a) => [[a,:b],:l] +; (fn(a,b,l);l) where fn(a,b,l) == +; null rest l => RPLAC(rest l,[[a,:b]]) +; a = l.1.0 => RPLAC(rest l.1,b) +; _?ORDER(l.1.0,a) => RPLAC(rest l,[[a,:b],:rest l]) +; fn(a,b,rest l) + +(DEFUN |insertAlist,fn| (|a| |b| |l|) + (SEQ + (IF (NULL (CDR |l|)) + (EXIT (RPLAC (CDR |l|) (CONS (CONS |a| |b|) NIL)))) + (IF (BOOT-EQUAL |a| (ELT (ELT |l| 1) 0)) + (EXIT (RPLAC (CDR (ELT |l| 1)) |b|))) + (IF (?ORDER (ELT (ELT |l| 1) 0) |a|) + (EXIT (RPLAC (CDR |l|) (CONS (CONS |a| |b|) (CDR |l|))))) + (EXIT (|insertAlist,fn| |a| |b| (CDR |l|))))) + +(DEFUN |insertAlist| (|a| |b| |l|) + (COND + ((NULL |l|) (CONS (CONS |a| |b|) NIL)) + ((BOOT-EQUAL |a| (ELT (ELT |l| 0) 0)) (RPLAC (CDAR |l|) |b|) |l|) + ((?ORDER (ELT (ELT |l| 0) 0) |a|) (CONS (CONS |a| |b|) |l|)) + ((QUOTE T) (|insertAlist,fn| |a| |b| |l|) |l|))) + +;--% Union +;Un2E(x,source,target) == +; ['Union,:branches] := source +; x = '_$fromCoerceable_$ => +; and/[canCoerce(t, target) for t in branches | ^ STRINGP t] +; coerceUn2E(x,source) + +(DEFUN |Un2E| (|x| |source| |target|) + (PROG (|branches|) + (RETURN + (SEQ + (PROGN + (SPADLET |branches| (CDR |source|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) + (PROG (#0=#:G170473) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G170480 NIL (NULL #0#)) + (#2=#:G170481 |branches| (CDR #2#)) + (|t| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |t| (CAR #2#)) NIL)) #0#) + (SEQ + (EXIT + (COND + ((NULL (STRINGP |t|)) + (SETQ #0# (AND #0# (|canCoerce| |t| |target|))))))))))) + ((QUOTE T) (|coerceUn2E| |x| |source|)))))))) + +;--% Variable +;Var2OV(u,source,target is [.,vl]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => MEMBER(sym,vl) +; MEMBER(sym,vl) => position1(sym,vl) +; coercionFailure() + +(DEFUN |Var2OV| (|u| |source| |target|) + (PROG (|vl| |sym|) + (RETURN + (PROGN + (SPADLET |vl| (CADR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|member| |sym| |vl|)) + ((|member| |sym| |vl|) (|position1| |sym| |vl|)) + ((QUOTE T) (|coercionFailure|))))))) + +;Var2Dmp(u,source,target is [dmp,vl,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) +; len := #vl +; -1 ^= (n:= position(sym,vl)) => +; LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], +; :getConstantFromDomain('(One),S)] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[Zeros len,:objValUnwrap u]] + +(DEFUN |Var2Dmp| (|u| |source| |target|) + (PROG (|dmp| |vl| S |sym| |len| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |dmp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|member| |sym| |vl|) (|canCoerce| |source| S))) + ((QUOTE T) + (SPADLET |len| (|#| |vl|)) + (COND + ((NEQUAL (SPADDIFFERENCE 1) (SPADLET |n| (|position| |sym| |vl|))) + (LIST + (CONS + (LIST2VEC + (PROG (#0=#:G170521) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G170526 (SPADDIFFERENCE |len| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND ((BOOT-EQUAL |n| |i|) 1) ((QUOTE T) 0)) #0#)))))))) + (|getConstantFromDomain| (QUOTE (|One|)) S)))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS (|Zeros| |len|) (|objValUnwrap| |u|)) NIL)))))))))) + +;Var2Gdmp(u,source,target is [dmp,vl,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) +; len := #vl +; -1 ^= (n:= position(sym,vl)) => +; LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], +; :getConstantFromDomain('(One),S)] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[Zeros len,:objValUnwrap u]] + +(DEFUN |Var2Gdmp| (|u| |source| |target|) + (PROG (|dmp| |vl| S |sym| |len| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |dmp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|member| |sym| |vl|) (|canCoerce| |source| S))) + ((QUOTE T) + (SPADLET |len| (|#| |vl|)) + (COND + ((NEQUAL (SPADDIFFERENCE 1) (SPADLET |n| (|position| |sym| |vl|))) + (LIST + (CONS + (LIST2VEC + (PROG (#0=#:G170557) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G170562 (SPADDIFFERENCE |len| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND ((BOOT-EQUAL |n| |i|) 1) ((QUOTE T) 0)) + #0#)))))))) + (|getConstantFromDomain| (QUOTE (|One|)) S)))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS (|Zeros| |len|) (|objValUnwrap| |u|)) NIL)))))))))) + +;Var2Mp(u,source,target is [mp,vl,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) +; (n:= position1(u,vl)) ^= 0 => +; [1,n,[1,0,:getConstantFromDomain('(One),S)]] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [0,:objValUnwrap u] + +(DEFUN |Var2Mp| (|u| |source| |target|) + (PROG (|mp| |vl| S |sym| |n|) + (RETURN + (PROGN + (SPADLET |mp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|member| |sym| |vl|) (|canCoerce| |source| S))) + ((NEQUAL (SPADLET |n| (|position1| |u| |vl|)) 0) + (CONS 1 + (CONS |n| + (CONS + (CONS 1 (CONS 0 (|getConstantFromDomain| (QUOTE (|One|)) S))) + NIL)))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS 0 (|objValUnwrap| |u|)))))))) + +;Var2NDmp(u,source,target is [ndmp,vl,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => MEMBER(sym,vl) or canCoerce(source,S) +; len:= #vl +; -1^=(n:= position(u,vl)) => +; LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], +; :getConstantFromDomain('(One),S)] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[Zeros len,:objValUnwrap(u)]] + +(DEFUN |Var2NDmp| (|u| |source| |target|) + (PROG (|ndmp| |vl| S |sym| |len| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |ndmp| (CAR |target|)) + (SPADLET |vl| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (|member| |sym| |vl|) (|canCoerce| |source| S))) + ((QUOTE T) + (SPADLET |len| (|#| |vl|)) + (COND + ((NEQUAL (SPADDIFFERENCE 1) (SPADLET |n| (|position| |u| |vl|))) + (LIST + (CONS + (LIST2VEC + (PROG (#0=#:G170613) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G170618 (SPADDIFFERENCE |len| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND ((BOOT-EQUAL |n| |i|) 1) ((QUOTE T) 0)) + #0#)))))))) + (|getConstantFromDomain| (QUOTE (|One|)) S)))) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS (|Zeros| |len|) (|objValUnwrap| |u|)) NIL)))))))))) + +;Var2P(u,source,target is [poly,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => true +; -- first try to get it into an underdomain +; if (S ^= $Integer) then +; u' := coerceInt(objNewWrap(u,source),S) +; if u' then return [0,:objValUnwrap(u')] +; -- if that failed, return it as a polynomial variable +; [1,sym,[1,0,:getConstantFromDomain('(One),S)]] + +(DEFUN |Var2P| (|u| |source| |target|) + (PROG (|poly| S |sym| |u'|) + (RETURN + (PROGN + (SPADLET |poly| (CAR |target|)) + (SPADLET S (CADR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) + (COND + ((NEQUAL S |$Integer|) + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (COND (|u'| (RETURN (CONS 0 (|objValUnwrap| |u'|)))) ((QUOTE T) NIL)))) + (CONS 1 + (CONS |sym| + (CONS + (CONS 1 (CONS 0 (|getConstantFromDomain| (QUOTE (|One|)) S))) + NIL))))))))) + +;Var2QF(u,source,target is [qf,S]) == +; u = '_$fromCoerceable_$ => canCoerce(source,S) +; S = $Integer => coercionFailure() +; sym := CADR source +; (u' := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [objValUnwrap u',:getConstantFromDomain('(One),S)] + +(DEFUN |Var2QF| (|u| |source| |target|) + (PROG (|qf| S |sym| |u'|) + (RETURN + (PROGN + (SPADLET |qf| (CAR |target|)) + (SPADLET S (CADR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| |source| S)) + ((BOOT-EQUAL S |$Integer|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |sym| (CADR |source|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS + (|objValUnwrap| |u'|) + (|getConstantFromDomain| (QUOTE (|One|)) S)))))))) + +;Var2FS(u,source,target is [fs,S]) == +; u = '_$fromCoerceable_$ => true +; (v := coerceInt(objNewWrap(u,source),['Polynomial,S])) or +; coercionFailure() +; (v := coerceInt(v,target)) or coercionFailure() +; objValUnwrap v + +(DEFUN |Var2FS| (|u| |source| |target|) + (PROG (|fs| S |v|) + (RETURN + (PROGN + (SPADLET |fs| (CAR |target|)) + (SPADLET S (CADR |target|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (QUOTE T)) + ((QUOTE T) + (OR + (SPADLET |v| + (|coerceInt| + (|objNewWrap| |u| |source|) + (CONS (QUOTE |Polynomial|) (CONS S NIL)))) + (|coercionFailure|)) + (OR (SPADLET |v| (|coerceInt| |v| |target|)) (|coercionFailure|)) + (|objValUnwrap| |v|))))))) + +;Var2Up(u,source,target is [up,x,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) +; x=sym => [[1,:getConstantFromDomain('(One),S)]] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[0,:objValUnwrap u]] + +(DEFUN |Var2Up| (|u| |source| |target|) + (PROG (|up| |x| S |sym|) + (RETURN + (PROGN + (SPADLET |up| (CAR |target|)) + (SPADLET |x| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (BOOT-EQUAL |sym| |x|) (|canCoerce| |source| S))) + ((BOOT-EQUAL |x| |sym|) + (CONS (CONS 1 (|getConstantFromDomain| (QUOTE (|One|)) S)) NIL)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u|)) NIL))))))) + +;Var2SUP(u,source,target is [sup,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => (sym = "?") or canCoerce(source,S) +; sym = "?" => [[1,:getConstantFromDomain('(One),S)]] +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; [[0,:objValUnwrap u]] + +(DEFUN |Var2SUP| (|u| |source| |target|) + (PROG (|sup| S |sym|) + (RETURN + (PROGN + (SPADLET |sup| (CAR |target|)) + (SPADLET S (CADR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (BOOT-EQUAL |sym| (QUOTE ?)) (|canCoerce| |source| S))) + ((BOOT-EQUAL |sym| (QUOTE ?)) + (CONS (CONS 1 (|getConstantFromDomain| (QUOTE (|One|)) S)) NIL)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (CONS (CONS 0 (|objValUnwrap| |u|)) NIL))))))) + +;Var2UpS(u,source,target is [ups,x,S]) == +; sym := CADR source +; u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) +; mid := ['UnivariatePolynomial,x,S] +; x = sym => +; u := Var2Up(u,source,mid) +; (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() +; objValUnwrap u +; (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() +; (u := coerceInt(u,target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |Var2UpS| (|u| |source| |target|) + (PROG (|ups| |x| S |sym| |mid|) + (RETURN + (PROGN + (SPADLET |ups| (CAR |target|)) + (SPADLET |x| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR (BOOT-EQUAL |sym| |x|) (|canCoerce| |source| S))) + ((QUOTE T) + (SPADLET |mid| + (CONS (QUOTE |UnivariatePolynomial|) (CONS |x| (CONS S NIL)))) + (COND + ((BOOT-EQUAL |x| |sym|) + (SPADLET |u| (|Var2Up| |u| |source| |mid|)) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |mid|) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|)) + ((QUOTE T) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |source|) S)) + (|coercionFailure|)) + (OR + (SPADLET |u| (|coerceInt| |u| |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))))) + +;Var2OtherPS(u,source,target is [.,x,S]) == +; sym := CADR source +; mid := ['UnivariatePowerSeries,x,S] +; u = '_$fromCoerceable_$ => +; (sym = x) or (canCoerce(source,mid) and canCoerce(mid,target)) +; u := Var2UpS(u,source,mid) +; (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() +; objValUnwrap u + +(DEFUN |Var2OtherPS| (|u| |source| |target|) + (PROG (|x| S |sym| |mid|) + (RETURN + (PROGN + (SPADLET |x| (CADR |target|)) + (SPADLET S (CADDR |target|)) + (SPADLET |sym| (CADR |source|)) + (SPADLET |mid| + (CONS (QUOTE |UnivariatePowerSeries|) (CONS |x| (CONS S NIL)))) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (OR + (BOOT-EQUAL |sym| |x|) + (AND (|canCoerce| |source| |mid|) (|canCoerce| |mid| |target|)))) + ((QUOTE T) + (SPADLET |u| (|Var2UpS| |u| |source| |mid|)) + (OR + (SPADLET |u| (|coerceInt| (|objNewWrap| |u| |mid|) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u|))))))) + +;--% Vector +;V2M(u,[.,D],[.,R]) == +; u = '_$fromCoerceable_$ => +; D is ['Vector,:.] => nil -- don't have data +; canCoerce(D,R) +; -- first see if we are coercing a vector of vectors +; D is ['Vector,E] and +; isRectangularVector(u,MAXINDEX u,MAXINDEX u.0) => +; LIST2VEC +; [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) +; for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] +; -- if not, try making it into a 1 by n matrix +; coercionFailure() + +(DEFUN V2M (|u| #0=#:G170765 #1=#:G170776) + (PROG (R D |ISTMP#1| E |x|) + (RETURN + (SEQ + (PROGN + (SPADLET R (CADR #1#)) + (SPADLET D (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((AND (PAIRP D) (EQ (QCAR D) (QUOTE |Vector|))) NIL) + ((QUOTE T) (|canCoerce| D R)))) + ((AND (PAIRP D) + (EQ (QCAR D) (QUOTE |Vector|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularVector| |u| (MAXINDEX |u|) (MAXINDEX (ELT |u| 0)))) + (LIST2VEC + (PROG (#2=#:G170794) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G170799 (MAXINDEX |u|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #3#) (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (LIST2VEC + (PROG (#4=#:G170807) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G170812 (MAXINDEX (SPADLET |x| (ELT |u| |i|)))) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| #5#) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|objValUnwrap| + (|coerceInt| (|objNewWrap| (ELT |x| |j|) E) R)) + #4#)))))))) + #2#))))))))) + ((QUOTE T) (|coercionFailure|)))))))) + +;--LIST2VEC [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(u.i,D),R)) +;-- for i in 0..MAXINDEX(u)]] +;V2Rm(u,[.,D],[.,n,m,R]) == +; u = '_$fromCoerceable_$ => nil +; D is [.,E,:.] and isRectangularVector(u,n-1,m-1) => +; LIST2VEC +; [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) +; for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] +; coercionFailure() + +(DEFUN |V2Rm| (|u| #0=#:G170831 #1=#:G170842) + (PROG (|n| |m| R D |ISTMP#1| E |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |n| (CADR #1#)) + (SPADLET |m| (CADDR #1#)) + (SPADLET R (CADDDR #1#)) + (SPADLET D (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP D) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularVector| |u| + (SPADDIFFERENCE |n| 1) + (SPADDIFFERENCE |m| 1))) + (LIST2VEC + (PROG (#2=#:G170864) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G170869 (MAXINDEX |u|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #3#) (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (LIST2VEC + (PROG (#4=#:G170877) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G170882 (MAXINDEX (SPADLET |x| (ELT |u| |i|)))) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| #5#) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|objValUnwrap| + (|coerceInt| (|objNewWrap| (ELT |x| |j|) E) R)) + #4#)))))))) + #2#))))))))) + ((QUOTE T) (|coercionFailure|)))))))) + +;V2Sm(u,[.,D],[.,n,R]) == +; u = '_$fromCoerceable_$ => nil +; D is [.,E,:.] and isRectangularVector(u,n-1,n-1) => +; LIST2VEC +; [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) +; for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] +; coercionFailure() + +(DEFUN |V2Sm| (|u| #0=#:G170903 #1=#:G170914) + (PROG (|n| R D |ISTMP#1| E |x|) + (RETURN + (SEQ + (PROGN + (SPADLET |n| (CADR #1#)) + (SPADLET R (CADDR #1#)) + (SPADLET D (CADR #0#)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP D) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET E (QCAR |ISTMP#1|)) (QUOTE T)))) + (|isRectangularVector| |u| + (SPADDIFFERENCE |n| 1) + (SPADDIFFERENCE |n| 1))) + (LIST2VEC + (PROG (#2=#:G170934) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G170939 (MAXINDEX |u|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #3#) (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (LIST2VEC + (PROG (#4=#:G170947) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G170952 (MAXINDEX (SPADLET |x| (ELT |u| |i|)))) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| #5#) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|objValUnwrap| + (|coerceInt| (|objNewWrap| (ELT |x| |j|) E) R)) + #4#)))))))) + #2#))))))))) + ((QUOTE T) (|coercionFailure|)))))))) + +;isRectangularVector(x,p,q) == +; MAXINDEX x = p => +; and/[q=MAXINDEX x.i for i in 0..p] + +(DEFUN |isRectangularVector| (|x| |p| |q|) + (PROG NIL + (RETURN + (SEQ + (COND + ((BOOT-EQUAL (MAXINDEX |x|) |p|) + (EXIT + (PROG (#0=#:G170967) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G170973 NIL (NULL #0#)) (|i| 0 (QSADD1 |i|))) + ((OR #1# (QSGREATERP |i| |p|)) #0#) + (SEQ + (EXIT + (SETQ #0# + (AND #0# (BOOT-EQUAL |q| (MAXINDEX (ELT |x| |i|))))))))))))))))) + +;-- Polynomial and Expression to Univariate series types +;P2Uts(u, source, target) == +; P2Us(u,source, target, 'taylor) + +(DEFUN |P2Uts| (|u| |source| |target|) + (|P2Us| |u| |source| |target| (QUOTE |taylor|))) + +;P2Uls(u, source, target) == +; P2Us(u,source, target, 'laurent) + +(DEFUN |P2Uls| (|u| |source| |target|) + (|P2Us| |u| |source| |target| (QUOTE |laurent|))) + +;P2Upxs(u, source, target) == +; P2Us(u,source, target, 'puiseux) + +(DEFUN |P2Upxs| (|u| |source| |target|) + (|P2Us| |u| |source| |target| (QUOTE |puiseux|))) + +;P2Us(u, source is [.,S], target is [.,T,var,cen], type) == +; u = '_$fromCoerceable_$ => +; -- might be able to say yes +; canCoerce(S,T) +; T isnt ['Expression, :.] => coercionFailure() +; if S ^= '(Float) then S := $Integer +; obj := objNewWrap(u, source) +; E := ['Expression, S] +; newU := coerceInt(obj, E) +; null newU => coercionFailure() +; EQtype := ['Equation, E] +; eqfun := getFunctionFromDomain('_=, EQtype, [E,E]) +; varE := coerceInt(objNewWrap(var, '(Symbol)), E) +; null varE => coercionFailure() +; cenE := coerceInt(objNewWrap(cen, T), E) +; null cenE => coercionFailure() +; eq := SPADCALL(objValUnwrap(varE), objValUnwrap(cenE), eqfun) +; package := ['ExpressionToUnivariatePowerSeries, S, E] +; func := getFunctionFromDomain(type, package, [E, EQtype]) +; newObj := SPADCALL(objValUnwrap(newU), eq, func) +; newType := CAR newObj +; newVal := CDR newObj +; newType = target => newVal +; finalObj := coerceInt(objNewWrap(newVal, newType), target) +; null finalObj => coercionFailure() +; objValUnwrap finalObj + +(DEFUN |P2Us| (|u| |source| |target| |type|) + (PROG (T$ |var| |cen| S |obj| E |newU| |EQtype| |eqfun| |varE| |cenE| |eq| + |package| |func| |newObj| |newType| |newVal| |finalObj|) + (RETURN + (PROGN + (SPADLET T$ (CADR |target|)) + (SPADLET |var| (CADDR |target|)) + (SPADLET |cen| (CADDDR |target|)) + (SPADLET S (CADR |source|)) + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S T$)) + ((NULL (AND (PAIRP T$) (EQ (QCAR T$) (QUOTE |Expression|)))) + (|coercionFailure|)) + ((QUOTE T) + (COND ((NEQUAL S (QUOTE (|Float|))) (SPADLET S |$Integer|))) + (SPADLET |obj| (|objNewWrap| |u| |source|)) + (SPADLET E (CONS (QUOTE |Expression|) (CONS S NIL))) + (SPADLET |newU| (|coerceInt| |obj| E)) + (COND + ((NULL |newU|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |EQtype| (CONS (QUOTE |Equation|) (CONS E NIL))) + (SPADLET |eqfun| + (|getFunctionFromDomain| (QUOTE =) |EQtype| (CONS E (CONS E NIL)))) + (SPADLET |varE| + (|coerceInt| (|objNewWrap| |var| (QUOTE (|Symbol|))) E)) + (COND + ((NULL |varE|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |cenE| (|coerceInt| (|objNewWrap| |cen| T$) E)) + (COND + ((NULL |cenE|) (|coercionFailure|)) + ((QUOTE T) + (SPADLET |eq| + (SPADCALL + (|objValUnwrap| |varE|) + (|objValUnwrap| |cenE|) + |eqfun|)) + (SPADLET |package| + (CONS + (QUOTE |ExpressionToUnivariatePowerSeries|) + (CONS S (CONS E NIL)))) + (SPADLET |func| + (|getFunctionFromDomain| |type| |package| + (CONS E (CONS |EQtype| NIL)))) + (SPADLET |newObj| (SPADCALL (|objValUnwrap| |newU|) |eq| |func|)) + (SPADLET |newType| (CAR |newObj|)) + (SPADLET |newVal| (CDR |newObj|)) + (COND + ((BOOT-EQUAL |newType| |target|) |newVal|) + ((QUOTE T) + (SPADLET |finalObj| + (|coerceInt| (|objNewWrap| |newVal| |newType|) |target|)) + (COND + ((NULL |finalObj|) (|coercionFailure|)) + ((QUOTE T) (|objValUnwrap| |finalObj|))))))))))))))))) + +;--% General Coercion Commutation Functions +;-- general commutation functions are called with 5 values +;-- u object of type source +;-- source type of u +;-- S underdomain of source +;-- target coercion target type +;-- T underdomain of T +;-- Because of checking, can always assume S and T have underdomains. +;--% Complex +;commuteComplex(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => +; canCoerce(S,target) and canCoerce(T,target) +; [real,:imag] := u +; (real := coerceInt(objNewWrap(real,S),target)) or coercionFailure() +; (imag := coerceInt(objNewWrap(imag,S),target)) or coercionFailure() +; T' := underDomainOf T +; i := [domainZero(T'), +; :domainOne(T')] +; (i := coerceInt(objNewWrap(i,T),target)) or coercionFailure() +; f := getFunctionFromDomain("*",target,[target,target]) +; i := SPADCALL(objValUnwrap i, objValUnwrap imag, f) +; f := getFunctionFromDomain("+",target,[target,target]) +; SPADCALL(objValUnwrap real,i,f) + +(DEFUN |commuteComplex| (|u| |source| S |target| T$) + (PROG (|real| |imag| |T'| |i| |f|) + (RETURN + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (AND (|canCoerce| S |target|) (|canCoerce| T$ |target|))) + ((QUOTE T) + (SPADLET |real| (CAR |u|)) + (SPADLET |imag| (CDR |u|)) + (OR + (SPADLET |real| (|coerceInt| (|objNewWrap| |real| S) |target|)) + (|coercionFailure|)) + (OR + (SPADLET |imag| (|coerceInt| (|objNewWrap| |imag| S) |target|)) + (|coercionFailure|)) + (SPADLET |T'| (|underDomainOf| T$)) + (SPADLET |i| (CONS (|domainZero| |T'|) (|domainOne| |T'|))) + (OR + (SPADLET |i| (|coerceInt| (|objNewWrap| |i| T$) |target|)) + (|coercionFailure|)) + (SPADLET |f| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |i| (SPADCALL (|objValUnwrap| |i|) (|objValUnwrap| |imag|) |f|)) + (SPADLET |f| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL (|objValUnwrap| |real|) |i| |f|)))))) + +;--% Quaternion +;commuteQuaternion(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => +; canCoerce(S,target) and canCoerce(T,target) +; c := [objValUnwrap(coerceInt(objNewWrap(x,S),target) +; or coercionFailure()) for x in VEC2LIST u] +; q := '(Quaternion (Integer)) +; e := [[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]] +; e := [(coerceInt(objNewWrap(LIST2VEC x,q),T) +; or coercionFailure()) for x in e] +; e :=[objValUnwrap(coerceInt(x,target) or coercionFailure()) for x in e] +; u' := domainZero(target) +; mult := getFunctionFromDomain("*",target,[target,target]) +; plus := getFunctionFromDomain("+",target,[target,target]) +; for x in c for y in e repeat +; u' := SPADCALL(u',SPADCALL(x,y,mult),plus) +; u' + +(DEFUN |commuteQuaternion| (|u| |source| S |target| T$) + (PROG (|c| |q| |e| |mult| |plus| |u'|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (AND (|canCoerce| S |target|) (|canCoerce| T$ |target|))) + ((QUOTE T) + (SPADLET |c| + (PROG (#0=#:G171055) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G171060 (VEC2LIST |u|) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (|objValUnwrap| + (OR + (|coerceInt| (|objNewWrap| |x| S) |target|) + (|coercionFailure|))) + #0#)))))))) + (SPADLET |q| (QUOTE (|Quaternion| (|Integer|)))) + (SPADLET |e| + (CONS + (CONS 1 (CONS 0 (CONS 0 (CONS 0 NIL)))) + (CONS + (CONS 0 (CONS 1 (CONS 0 (CONS 0 NIL)))) + (CONS + (CONS 0 (CONS 0 (CONS 1 (CONS 0 NIL)))) + (CONS (CONS 0 (CONS 0 (CONS 0 (CONS 1 NIL)))) NIL))))) + (SPADLET |e| + (PROG (#2=#:G171070) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G171075 |e| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (OR + (|coerceInt| (|objNewWrap| (LIST2VEC |x|) |q|) T$) + (|coercionFailure|)) + #2#)))))))) + (SPADLET |e| + (PROG (#4=#:G171085) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G171090 |e| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|objValUnwrap| + (OR (|coerceInt| |x| |target|) (|coercionFailure|))) + #4#)))))))) + (SPADLET |u'| (|domainZero| |target|)) + (SPADLET |mult| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (DO ((#6=#:G171100 |c| (CDR #6#)) + (|x| NIL) + (#7=#:G171101 |e| (CDR #7#)) + (|y| NIL)) + ((OR (ATOM #6#) + (PROGN (SETQ |x| (CAR #6#)) NIL) + (ATOM #7#) + (PROGN (SETQ |y| (CAR #7#)) NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |u'| (SPADCALL |u'| (SPADCALL |x| |y| |mult|) |plus|))))) + |u'|)))))) + +;--% Fraction +;commuteFraction(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => +; ofCategory(target,'(Field)) => canCoerce(S,target) +; canCoerce(S,T) and canCoerce(T,target) +; [n,:d] := u +; ofCategory(target,'(Field)) => +; -- see if denominator can go over to target +; (d' := coerceInt(objNewWrap(d,S),target)) or coercionFailure() +; -- if so, try to invert it +; inv := getFunctionFromDomain('inv,target,[target]) +; d' := SPADCALL(objValUnwrap d',inv) +; -- now coerce to target +; (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() +; multfunc := getFunctionFromDomain("*",target,[target,target]) +; SPADCALL(d',objValUnwrap n',multfunc) +; -- see if denominator can go over to QF part of target +; (d' := coerceInt(objNewWrap(d,S),T)) or coercionFailure() +; -- if so, try to invert it +; inv := getFunctionFromDomain('inv,T,[T]) +; d' := SPADCALL(objValUnwrap d',inv) +; -- now coerce to target +; (d' := coerceInt(objNewWrap(d',T),target)) or coercionFailure() +; (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() +; multfunc := getFunctionFromDomain("*",target,[target,target]) +; SPADCALL(objValUnwrap d',objValUnwrap n',multfunc) + +(DEFUN |commuteFraction| (|u| |source| S |target| T$) + (PROG (|n| |d| |inv| |d'| |n'| |multfunc|) + (RETURN + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (COND + ((|ofCategory| |target| (QUOTE (|Field|))) (|canCoerce| S |target|)) + ((QUOTE T) (AND (|canCoerce| S T$) (|canCoerce| T$ |target|))))) + ((QUOTE T) + (SPADLET |n| (CAR |u|)) + (SPADLET |d| (CDR |u|)) + (COND + ((|ofCategory| |target| (QUOTE (|Field|))) + (OR + (SPADLET |d'| (|coerceInt| (|objNewWrap| |d| S) |target|)) + (|coercionFailure|)) + (SPADLET |inv| + (|getFunctionFromDomain| (QUOTE |inv|) |target| (CONS |target| NIL))) + (SPADLET |d'| (SPADCALL (|objValUnwrap| |d'|) |inv|)) + (OR + (SPADLET |n'| (|coerceInt| (|objNewWrap| |n| S) |target|)) + (|coercionFailure|)) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL |d'| (|objValUnwrap| |n'|) |multfunc|)) + ((QUOTE T) + (OR + (SPADLET |d'| (|coerceInt| (|objNewWrap| |d| S) T$)) + (|coercionFailure|)) + (SPADLET |inv| (|getFunctionFromDomain| (QUOTE |inv|) T$ (CONS T$ NIL))) + (SPADLET |d'| (SPADCALL (|objValUnwrap| |d'|) |inv|)) + (OR + (SPADLET |d'| (|coerceInt| (|objNewWrap| |d'| T$) |target|)) + (|coercionFailure|)) + (OR + (SPADLET |n'| (|coerceInt| (|objNewWrap| |n| S) |target|)) + (|coercionFailure|)) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL + (|objValUnwrap| |d'|) + (|objValUnwrap| |n'|) + |multfunc|)))))))) + +;--% SquareMatrix +;commuteSquareMatrix(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => +; canCoerce(S,target) and canCoerce(T,target) +; -- commuting matrices of matrices should be a no-op +; S is ['SquareMatrix,:.] => +; source=target => u +; coercionFailure() +; u' := domainZero(target) +; plusfunc := getFunctionFromDomain("+",target,[target,target]) +; multfunc := getFunctionFromDomain("*",target,[target,target]) +; zero := domainZero(S) +; [sm,n,:.] := source +; S' := [sm,n,$Integer] +; for i in 0..(n-1) repeat +; for j in 0..(n-1) repeat +; (e := u.i.j) = zero => 'iterate +; (e' := coerceInt(objNewWrap(e,S),target)) or coercionFailure() +; (Eij := coerceInt(objNewWrap(makeEijSquareMatrix(i,j,n),S'),T)) or +; coercionFailure() +; (Eij := coerceInt(Eij,target)) or coercionFailure() +; e' := SPADCALL(objValUnwrap(e'),objValUnwrap(Eij),multfunc) +; u' := SPADCALL(e',u',plusfunc) +; u' + +(DEFUN |commuteSquareMatrix| (|u| |source| S |target| T$) + (PROG (|plusfunc| |multfunc| |zero| |sm| |n| |S'| |e| |Eij| |e'| |u'|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (AND (|canCoerce| S |target|) (|canCoerce| T$ |target|))) + ((AND (PAIRP S) (EQ (QCAR S) (QUOTE |SquareMatrix|))) + (COND + ((BOOT-EQUAL |source| |target|) |u|) + ((QUOTE T) (|coercionFailure|)))) + ((QUOTE T) + (SPADLET |u'| (|domainZero| |target|)) + (SPADLET |plusfunc| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfunc| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |zero| (|domainZero| S)) + (SPADLET |sm| (CAR |source|)) + (SPADLET |n| (CADR |source|)) + (SPADLET |S'| (CONS |sm| (CONS |n| (CONS |$Integer| NIL)))) + (DO ((#0=#:G171156 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #0#) NIL) + (SEQ + (EXIT + (DO ((#1=#:G171163 (SPADDIFFERENCE |n| 1)) (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| #1#) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (SPADLET |e| (ELT (ELT |u| |i|) |j|)) |zero|) + (QUOTE |iterate|)) + ((QUOTE T) + (OR + (SPADLET |e'| (|coerceInt| (|objNewWrap| |e| S) |target|)) + (|coercionFailure|)) + (OR + (SPADLET |Eij| + (|coerceInt| + (|objNewWrap| (|makeEijSquareMatrix| |i| |j| |n|) |S'|) T$)) + (|coercionFailure|)) + (OR + (SPADLET |Eij| (|coerceInt| |Eij| |target|)) + (|coercionFailure|)) + (SPADLET |e'| + (SPADCALL + (|objValUnwrap| |e'|) + (|objValUnwrap| |Eij|) + |multfunc|)) + (SPADLET |u'| (SPADCALL |e'| |u'| |plusfunc|)))))))))) + |u'|)))))) +;makeEijSquareMatrix(i, j, dim) == +; -- assume using 0 based scale, makes a dim by dim matrix with a +; -- 1 in the i,j position, zeros elsewhere +; LIST2VEC [LIST2VEC [((i=r) and (j=c) => 1; 0) +; for c in 0..(dim-1)] for r in 0..(dim-1)] + +(DEFUN |makeEijSquareMatrix| (|i| |j| |dim|) + (PROG NIL + (RETURN + (SEQ + (LIST2VEC + (PROG (#0=#:G171188) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G171193 (SPADDIFFERENCE |dim| 1)) (|r| 0 (QSADD1 |r|))) + ((QSGREATERP |r| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (LIST2VEC + (PROG (#2=#:G171201) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G171206 (SPADDIFFERENCE |dim| 1)) + (|c| 0 (QSADD1 |c|))) + ((QSGREATERP |c| #3#) (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (COND + ((AND (BOOT-EQUAL |i| |r|) (BOOT-EQUAL |j| |c|)) 1) + ((QUOTE T) 0)) #2#)))))))) + #0#)))))))))))) + +;--% Univariate Polynomial and Sparse Univariate Polynomial +;commuteUnivariatePolynomial(u,source,S,target,T) == +; commuteSparseUnivariatePolynomial(u,source,S,target,T) + +(DEFUN |commuteUnivariatePolynomial| (|u| |source| S |target| T$) + (|commuteSparseUnivariatePolynomial| |u| |source| S |target| T$)) + +;commuteSparseUnivariatePolynomial(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => +; canCoerce(S,target) and canCoerce(T,target) +; u' := domainZero(target) +; null u => u' +; T' := underDomainOf T +; one := domainOne(T') +; monom := getFunctionFromDomain('monomial,T,[T',$NonNegativeInteger]) +; plus := getFunctionFromDomain("+",target,[target,target]) +; times := getFunctionFromDomain("*",target,[target,target]) +; for [e,:c] in u repeat +; (c := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; m := SPADCALL(one,e,monom) +; (m := coerceInt(objNewWrap(m,T),target)) or coercionFailure() +; c := objValUnwrap c +; m := objValUnwrap m +; u' := SPADCALL(u',SPADCALL(c,m,times),plus) +; u' + +(DEFUN |commuteSparseUnivariatePolynomial| (|u| |source| S |target| T$) + (PROG (|T'| |one| |monom| |plus| |times| |e| |c| |m| |u'|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) + (AND (|canCoerce| S |target|) (|canCoerce| T$ |target|))) + ((QUOTE T) + (SPADLET |u'| (|domainZero| |target|)) + (COND + ((NULL |u|) |u'|) + ((QUOTE T) + (SPADLET |T'| (|underDomainOf| T$)) + (SPADLET |one| (|domainOne| |T'|)) + (SPADLET |monom| + (|getFunctionFromDomain| + (QUOTE |monomial|) + T$ + (CONS |T'| (CONS |$NonNegativeInteger| NIL)))) + (SPADLET |plus| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |times| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (DO ((#0=#:G171234 |u| (CDR #0#)) (#1=#:G171219 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |e| (CAR #1#)) (SPADLET |c| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (OR + (SPADLET |c| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (SPADLET |m| (SPADCALL |one| |e| |monom|)) + (OR + (SPADLET |m| (|coerceInt| (|objNewWrap| |m| T$) |target|)) + (|coercionFailure|)) + (SPADLET |c| (|objValUnwrap| |c|)) + (SPADLET |m| (|objValUnwrap| |m|)) + (SPADLET |u'| + (SPADCALL |u'| (SPADCALL |c| |m| |times|) |plus|)))))) + |u'|)))))))) + +;--% Multivariate Polynomials +;commutePolynomial(u,source,S,target,T) == +; commuteMPolyCat(u,source,S,target,T) + +(DEFUN |commutePolynomial| (|u| |source| S |target| T$) + (|commuteMPolyCat| |u| |source| S |target| T$)) + +;commuteMultivariatePolynomial(u,source,S,target,T) == +; commuteMPolyCat(u,source,S,target,T) + +(DEFUN |commuteMultivariatePolynomial| (|u| |source| S |target| T$) + (|commuteMPolyCat| |u| |source| S |target| T$)) + +;commuteDistributedMultivariatePolynomial(u,source,S,target,T) == +; commuteMPolyCat(u,source,S,target,T) + +(DEFUN |commuteDistributedMultivariatePolynomial| (|u| |source| S |target| T$) + (|commuteMPolyCat| |u| |source| S |target| T$)) + +;commuteNewDistributedMultivariatePolynomial(u,source,S,target,T) == +; commuteMPolyCat(u,source,S,target,T) + +(DEFUN |commuteNewDistributedMultivariatePolynomial| + (|u| |source| S |target| T$) + (|commuteMPolyCat| |u| |source| S |target| T$)) + +;commuteMPolyCat(u,source,S,target,T) == +; u = '_$fromCoerceable_$ => canCoerce(S,target) +; -- check constant case +; isconstfun := getFunctionFromDomain("ground?",source,[source]) +; SPADCALL(u,isconstfun) => +; constfun := getFunctionFromDomain("ground",source,[source]) +; c := SPADCALL(u,constfun) +; (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() +; objValUnwrap(u') +; lmfun := getFunctionFromDomain('leadingMonomial,source,[source]) +; lm := SPADCALL(u,lmfun) -- has type source, is leading monom +; lcfun := getFunctionFromDomain('leadingCoefficient,source,[source]) +; lc := SPADCALL(lm,lcfun) -- has type S, is leading coef +; (lc' := coerceInt(objNewWrap(lc,S),target)) or coercionFailure() +; pmfun := getFunctionFromDomain('primitiveMonomials,source,[source]) +; lm := first SPADCALL(lm,pmfun) -- now we have removed the leading coef +; (lm' := coerceInt(objNewWrap(lm,source),T)) or coercionFailure() +; (lm' := coerceInt(lm',target)) or coercionFailure() +; rdfun := getFunctionFromDomain('reductum,source,[source]) +; rd := SPADCALL(u,rdfun) -- has type source, is reductum +; (rd' := coerceInt(objNewWrap(rd,source),target)) or coercionFailure() +; lc' := objValUnwrap lc' +; lm' := objValUnwrap lm' +; rd' := objValUnwrap rd' +; plusfun := getFunctionFromDomain("+",target,[target,target]) +; multfun := getFunctionFromDomain("*",target,[target,target]) +; SPADCALL(SPADCALL(lc',lm',multfun),rd',plusfun) + +(DEFUN |commuteMPolyCat| (|u| |source| S |target| T$) + (PROG (|isconstfun| |constfun| |c| |u'| |lmfun| |lcfun| |lc| |pmfun| |lm| + |rdfun| |rd| |lc'| |lm'| |rd'| |plusfun| |multfun|) + (RETURN + (COND + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) (|canCoerce| S |target|)) + ((QUOTE T) + (SPADLET |isconstfun| + (|getFunctionFromDomain| (QUOTE |ground?|) |source| (CONS |source| NIL))) + (COND + ((SPADCALL |u| |isconstfun|) + (SPADLET |constfun| + (|getFunctionFromDomain| + (QUOTE |ground|) + |source| + (CONS |source| NIL))) + (SPADLET |c| (SPADCALL |u| |constfun|)) + (OR + (SPADLET |u'| (|coerceInt| (|objNewWrap| |c| S) |target|)) + (|coercionFailure|)) + (|objValUnwrap| |u'|)) + ((QUOTE T) + (SPADLET |lmfun| + (|getFunctionFromDomain| + (QUOTE |leadingMonomial|) + |source| + (CONS |source| NIL))) + (SPADLET |lm| (SPADCALL |u| |lmfun|)) + (SPADLET |lcfun| + (|getFunctionFromDomain| + (QUOTE |leadingCoefficient|) + |source| + (CONS |source| NIL))) + (SPADLET |lc| (SPADCALL |lm| |lcfun|)) + (OR + (SPADLET |lc'| (|coerceInt| (|objNewWrap| |lc| S) |target|)) + (|coercionFailure|)) + (SPADLET |pmfun| + (|getFunctionFromDomain| + (QUOTE |primitiveMonomials|) + |source| + (CONS |source| NIL))) + (SPADLET |lm| (CAR (SPADCALL |lm| |pmfun|))) + (OR + (SPADLET |lm'| (|coerceInt| (|objNewWrap| |lm| |source|) T$)) + (|coercionFailure|)) + (OR (SPADLET |lm'| (|coerceInt| |lm'| |target|)) (|coercionFailure|)) + (SPADLET |rdfun| + (|getFunctionFromDomain| + (QUOTE |reductum|) + |source| + (CONS |source| NIL))) + (SPADLET |rd| (SPADCALL |u| |rdfun|)) + (OR + (SPADLET |rd'| (|coerceInt| (|objNewWrap| |rd| |source|) |target|)) + (|coercionFailure|)) + (SPADLET |lc'| (|objValUnwrap| |lc'|)) + (SPADLET |lm'| (|objValUnwrap| |lm'|)) + (SPADLET |rd'| (|objValUnwrap| |rd'|)) + (SPADLET |plusfun| + (|getFunctionFromDomain| + (QUOTE +) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADLET |multfun| + (|getFunctionFromDomain| + (QUOTE *) + |target| + (CONS |target| (CONS |target| NIL)))) + (SPADCALL (SPADCALL |lc'| |lm'| |multfun|) |rd'| |plusfun|)))))))) + +@ +\begin{verbatim} + + Format for alist member is: domain coercionType function + here coercionType can be one of 'total, 'partial or 'indeterm + (indeterminant - cannot tell in a simple way). + + In terms of canCoerceFrom, 'total implies true, 'partial implies + false (just cannot tell without actual data) and 'indeterm means + to call the function with the data = "$fromCoerceable$" for a + response of true or false. + + There are no entries here for RationalNumber or RationalFunction. + These should have been changed to QF I and QF P, respectively, by + a function like deconstructTower. RSS 8-1-85 + +\end{verbatim} +<<*>>= +;SETANDFILEQ($CoerceTable, '( _ +; (Complex . ( _ +; (Expression indeterm Complex2Expr) _ +; (Factored indeterm Complex2FR) _ +; (Integer partial Complex2underDomain) _ +; (PrimeField partial Complex2underDomain) _ +; ))_ +; (DirectProduct . ( _ +; (DirectProduct partial DP2DP) _ +; )) _ +; (DistributedMultivariatePolynomial . ( _ +; (DistributedMultivariatePolynomial indeterm Dmp2Dmp) _ +; (Expression indeterm Dmp2Expr) _ +; (Factored indeterm Mp2FR) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm Dmp2NDmp) _ +; (MultivariatePolynomial indeterm Dmp2Mp) _ +; (Polynomial indeterm Dmp2P) _ +; (UnivariatePolynomial indeterm Dmp2Up) _ +; ))_ +; (Expression . ( +; (Complex partial Expr2Complex) _ +; (DistributedMultivariatePolynomial indeterm Expr2Dmp) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm Expr2Dmp) _ +; (MultivariatePolynomial indeterm Expr2Mp) _ +; (UnivariateLaurentSeries indeterm P2Uls) _ +; (UnivariatePolynomial indeterm Expr2Up) _ +; (UnivariatePuiseuxSeries indeterm P2Upxs) _ +; (UnivariateTaylorSeries indeterm P2Uts) _ +; )) _ +; (Kernel . ( _ +; (Kernel indeterm Ker2Ker) _ +; (Expression indeterm Ker2Expr) _ +; )) _ +; (Factored . ( _ +; (Factored indeterm Factored2Factored) _ +; ))_ +; (Fraction . ( _ +; (DistributedMultivariatePolynomial partial Qf2domain) _ +; (ElementaryFunction indeterm Qf2EF) _ +; (Expression indeterm Qf2EF) _ +; (Fraction indeterm Qf2Qf) _ +; (HomogeneousDistributedMultivariatePolynomial partial Qf2domain) _ +; (Integer partial Qf2domain) _ +; (MultivariatePolynomial partial Qf2domain) _ +; (Polynomial partial Qf2domain) _ +; (PrimeField indeterm Qf2PF) _ +; (UnivariateLaurentSeries indeterm P2Uls) _ +; (UnivariatePolynomial partial Qf2domain) _ +; (UnivariatePuiseuxSeries indeterm P2Upxs) _ +; (UnivariateTaylorSeries indeterm P2Uts) _ +; ))_ +; (Int . ( _ +; (Expression total ncI2E) _ +; (Integer total ncI2I) _ +; ))_ +; (Baby . ( _ +; (Expression total ncI2E) _ +; (Integer total ncI2I) _ +; ))_ +; (Integer . ( _ +; (Baby total I2ncI) _ +; (EvenInteger partial I2EI) _ +; (Int total I2ncI) _ +; (NonNegativeInteger partial I2NNI) _ +; (OddInteger partial I2OI) _ +; (PositiveInteger partial I2PI) _ +; ))_ +; (List . ( _ +; (DirectProduct indeterm L2DP) _ +; (Matrix partial L2M) _ +; (Record partial L2Record) _ +; (RectangularMatrix partial L2Rm) _ +; (Set indeterm L2Set) _ +; (SquareMatrix partial L2Sm) _ +; (Stream indeterm Agg2Agg) _ +; (Tuple indeterm L2Tuple) _ +; (Vector indeterm L2V) _ +; ))_ +; )) + +(SETANDFILEQ |$CoerceTable| + (QUOTE ( + (|Complex| + (|Expression| |indeterm| |Complex2Expr|) + (|Factored| |indeterm| |Complex2FR|) + (|Integer| |partial| |Complex2underDomain|) + (|PrimeField| |partial| |Complex2underDomain|)) + (|DirectProduct| + (|DirectProduct| |partial| DP2DP)) + (|DistributedMultivariatePolynomial| + (|DistributedMultivariatePolynomial| |indeterm| |Dmp2Dmp|) + (|Expression| |indeterm| |Dmp2Expr|) + (|Factored| |indeterm| |Mp2FR|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |Dmp2NDmp|) + (|MultivariatePolynomial| |indeterm| |Dmp2Mp|) + (|Polynomial| |indeterm| |Dmp2P|) + (|UnivariatePolynomial| |indeterm| |Dmp2Up|)) + (|Expression| + (|Complex| |partial| |Expr2Complex|) + (|DistributedMultivariatePolynomial| |indeterm| |Expr2Dmp|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |Expr2Dmp|) + (|MultivariatePolynomial| |indeterm| |Expr2Mp|) + (|UnivariateLaurentSeries| |indeterm| |P2Uls|) + (|UnivariatePolynomial| |indeterm| |Expr2Up|) + (|UnivariatePuiseuxSeries| |indeterm| |P2Upxs|) + (|UnivariateTaylorSeries| |indeterm| |P2Uts|)) + (|Kernel| + (|Kernel| |indeterm| |Ker2Ker|) + (|Expression| |indeterm| |Ker2Expr|)) + (|Factored| + (|Factored| |indeterm| |Factored2Factored|)) + (|Fraction| + (|DistributedMultivariatePolynomial| |partial| |Qf2domain|) + (|ElementaryFunction| |indeterm| |Qf2EF|) + (|Expression| |indeterm| |Qf2EF|) + (|Fraction| |indeterm| |Qf2Qf|) + (|HomogeneousDistributedMultivariatePolynomial| |partial| |Qf2domain|) + (|Integer| |partial| |Qf2domain|) + (|MultivariatePolynomial| |partial| |Qf2domain|) + (|Polynomial| |partial| |Qf2domain|) + (|PrimeField| |indeterm| |Qf2PF|) + (|UnivariateLaurentSeries| |indeterm| |P2Uls|) + (|UnivariatePolynomial| |partial| |Qf2domain|) + (|UnivariatePuiseuxSeries| |indeterm| |P2Upxs|) + (|UnivariateTaylorSeries| |indeterm| |P2Uts|)) + (|Int| + (|Expression| |total| |ncI2E|) + (|Integer| |total| |ncI2I|)) + (|Baby| + (|Expression| |total| |ncI2E|) + (|Integer| |total| |ncI2I|)) + (|Integer| + (|Baby| |total| |I2ncI|) + (|EvenInteger| |partial| I2EI) + (|Int| |total| |I2ncI|) + (|NonNegativeInteger| |partial| I2NNI) + (|OddInteger| |partial| I2OI) + (|PositiveInteger| |partial| I2PI)) + (|List| + (|DirectProduct| |indeterm| L2DP) + (|Matrix| |partial| L2M) + (|Record| |partial| |L2Record|) + (|RectangularMatrix| |partial| |L2Rm|) + (|Set| |indeterm| |L2Set|) + (|SquareMatrix| |partial| |L2Sm|) + (|Stream| |indeterm| |Agg2Agg|) + (|Tuple| |indeterm| |L2Tuple|) + (|Vector| |indeterm| L2V))))) + +;SETANDFILEQ($CoerceTable,NCONC($CoerceTable,'( _ +; (Matrix . ( _ +; (List indeterm M2L) _ +; (RectangularMatrix partial M2Rm) _ +; (SquareMatrix partial M2Sm) _ +; (Vector indeterm M2L) _ +; ))_ +; (MultivariatePolynomial . ( _ +; (DistributedMultivariatePolynomial indeterm Mp2Dmp) _ +; (Expression indeterm Mp2Expr) _ +; (Factored indeterm Mp2FR) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ +; (MultivariatePolynomial indeterm Mp2Mp) _ +; (Polynomial indeterm Mp2P) _ +; (UnivariatePolynomial indeterm Mp2Up) _ +; ))_ +; (HomogeneousDirectProduct . ( _ +; (HomogeneousDirectProduct indeterm DP2DP) _ +; ))_ +; (HomogeneousDistributedMultivariatePolynomial . ( _ +; (Complex indeterm NDmp2domain) _ +; (DistributedMultivariatePolynomial indeterm NDmp2domain) _ +; (Expression indeterm Dmp2Expr) _ +; (Factored indeterm Mp2FR) _ +; (Fraction indeterm NDmp2domain) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm NDmp2NDmp) _ +; (MultivariatePolynomial indeterm NDmp2domain) _ +; (Polynomial indeterm NDmp2domain) _ +; (Quaternion indeterm NDmp2domain) _ +; (UnivariatePolynomial indeterm NDmp2domain) _ +; ))_ +; (OrderedVariableList . ( _ +; (DistributedMultivariatePolynomial indeterm OV2poly) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm OV2poly) _ +; (MultivariatePolynomial indeterm OV2poly) _ +; (OrderedVariableList indeterm OV2OV) _ +; (Polynomial total OV2P) _ +; (Symbol total OV2Sy) _ +; (UnivariatePolynomial indeterm OV2poly) _ +; ))_ +; (Polynomial . ( _ +; (DistributedMultivariatePolynomial indeterm P2Dmp) _ +; (Expression indeterm P2Expr) _ +; (Factored indeterm P2FR) _ +; (HomogeneousDistributedMultivariatePolynomial partial domain2NDmp) _ +; (MultivariatePolynomial indeterm P2Mp) _ +; (UnivariateLaurentSeries indeterm P2Uls) _ +; (UnivariatePolynomial indeterm P2Up) _ +; (UnivariatePuiseuxSeries indeterm P2Upxs) _ +; (UnivariateTaylorSeries indeterm P2Uts) _ +; ))_ +; (Set . ( _ +; (List indeterm Set2L) _ +; (Vector indeterm Agg2L2Agg) _ +; ))_ +; (RectangularMatrix . ( _ +; (List indeterm Rm2L) _ +; (Matrix indeterm Rm2M) _ +; (SquareMatrix indeterm Rm2Sm) _ +; (Vector indeterm Rm2V) _ +; ))_ +; (SparseUnivariatePolynomial . ( _ +; (UnivariatePolynomial indeterm SUP2Up) _ +; ))_ +; (SquareMatrix . ( +; -- ones for polys needed for M[2] P I -> P[x,y] M[2] P I, say +; (DistributedMultivariatePolynomial partial Sm2PolyType) _ +; (HomogeneousDistributedMultivariatePolynomial partial Sm2PolyType) _ +; (List indeterm Sm2L) _ +; (Matrix indeterm Sm2M) _ +; (MultivariatePolynomial partial Sm2PolyType) _ +; (RectangularMatrix indeterm Sm2Rm) _ +; (UnivariatePolynomial indeterm Sm2PolyType) _ +; (Vector indeterm Sm2V) _ +; ) ) _ +; (Symbol . ( _ +; (DistributedMultivariatePolynomial indeterm Sy2Dmp) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm Sy2NDmp) _ +; (MultivariatePolynomial indeterm Sy2Mp) _ +; (OrderedVariableList partial Sy2OV) _ +; (Polynomial total Sy2P) _ +; (UnivariatePolynomial indeterm Sy2Up) _ +; (Variable indeterm Sy2Var) _ +; ) ) _ +; (UnivariatePolynomial . ( _ +; (DistributedMultivariatePolynomial indeterm Up2Dmp) _ +; (Expression indeterm Up2Expr) _ +; (Factored indeterm Up2FR) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ +; (MultivariatePolynomial indeterm Up2Mp) _ +; (Polynomial indeterm Up2P) _ +; (SparseUnivariatePolynomial indeterm Up2SUP) _ +; (UnivariatePolynomial indeterm Up2Up) _ +; ) ) _ +; (Variable . ( _ +; (AlgebraicFunction total Var2FS) _ +; (ContinuedFractionPowerSeries indeterm Var2OtherPS) _ +; (DistributedMultivariatePolynomial indeterm Var2Dmp) _ +; (ElementaryFunction total Var2FS) _ +; (Fraction indeterm Var2QF) _ +; (FunctionalExpression total Var2FS) _ +; (GeneralDistributedMultivariatePolynomial indeterm Var2Gdmp) _ +; (HomogeneousDistributedMultivariatePolynomial indeterm Var2NDmp) _ +; (LiouvillianFunction total Var2FS) _ +; (MultivariatePolynomial indeterm Var2Mp) _ +; (OrderedVariableList indeterm Var2OV) _ +; (Polynomial total Var2P) _ +; (SparseUnivariatePolynomial indeterm Var2SUP) _ +; (Symbol total Identity) _ +; (UnivariatePolynomial indeterm Var2Up) _ +; (UnivariatePowerSeries indeterm Var2UpS) _ +; ) ) _ +; (Vector . ( _ +; (DirectProduct indeterm V2DP) _ +; (List indeterm V2L) _ +; (Matrix indeterm V2M) _ +; (RectangularMatrix indeterm V2Rm) _ +; (Set indeterm Agg2L2Agg) _ +; (SquareMatrix indeterm V2Sm) _ +; (Stream indeterm Agg2Agg) _ +; ) ) _ +; ) ) ) + +(SETANDFILEQ |$CoerceTable| + (NCONC |$CoerceTable| + (QUOTE ( + (|Matrix| + (|List| |indeterm| M2L) + (|RectangularMatrix| |partial| |M2Rm|) + (|SquareMatrix| |partial| |M2Sm|) + (|Vector| |indeterm| M2L)) + (|MultivariatePolynomial| + (|DistributedMultivariatePolynomial| |indeterm| |Mp2Dmp|) + (|Expression| |indeterm| |Mp2Expr|) + (|Factored| |indeterm| |Mp2FR|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |domain2NDmp|) + (|MultivariatePolynomial| |indeterm| |Mp2Mp|) + (|Polynomial| |indeterm| |Mp2P|) + (|UnivariatePolynomial| |indeterm| |Mp2Up|)) + (|HomogeneousDirectProduct| (|HomogeneousDirectProduct| |indeterm| DP2DP)) + (|HomogeneousDistributedMultivariatePolynomial| + (|Complex| |indeterm| |NDmp2domain|) + (|DistributedMultivariatePolynomial| |indeterm| |NDmp2domain|) + (|Expression| |indeterm| |Dmp2Expr|) + (|Factored| |indeterm| |Mp2FR|) + (|Fraction| |indeterm| |NDmp2domain|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |NDmp2NDmp|) + (|MultivariatePolynomial| |indeterm| |NDmp2domain|) + (|Polynomial| |indeterm| |NDmp2domain|) + (|Quaternion| |indeterm| |NDmp2domain|) + (|UnivariatePolynomial| |indeterm| |NDmp2domain|)) + (|OrderedVariableList| + (|DistributedMultivariatePolynomial| |indeterm| |OV2poly|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |OV2poly|) + (|MultivariatePolynomial| |indeterm| |OV2poly|) + (|OrderedVariableList| |indeterm| OV2OV) + (|Polynomial| |total| OV2P) + (|Symbol| |total| |OV2Sy|) + (|UnivariatePolynomial| |indeterm| |OV2poly|)) + (|Polynomial| + (|DistributedMultivariatePolynomial| |indeterm| |P2Dmp|) + (|Expression| |indeterm| |P2Expr|) + (|Factored| |indeterm| P2FR) + (|HomogeneousDistributedMultivariatePolynomial| |partial| |domain2NDmp|) + (|MultivariatePolynomial| |indeterm| |P2Mp|) + (|UnivariateLaurentSeries| |indeterm| |P2Uls|) + (|UnivariatePolynomial| |indeterm| |P2Up|) + (|UnivariatePuiseuxSeries| |indeterm| |P2Upxs|) + (|UnivariateTaylorSeries| |indeterm| |P2Uts|)) + (|Set| + (|List| |indeterm| |Set2L|) + (|Vector| |indeterm| |Agg2L2Agg|)) + (|RectangularMatrix| + (|List| |indeterm| |Rm2L|) + (|Matrix| |indeterm| |Rm2M|) + (|SquareMatrix| |indeterm| |Rm2Sm|) + (|Vector| |indeterm| |Rm2V|)) + (|SparseUnivariatePolynomial| (|UnivariatePolynomial| |indeterm| |SUP2Up|)) + (|SquareMatrix| + (|DistributedMultivariatePolynomial| |partial| |Sm2PolyType|) + (|HomogeneousDistributedMultivariatePolynomial| |partial| |Sm2PolyType|) + (|List| |indeterm| |Sm2L|) + (|Matrix| |indeterm| |Sm2M|) + (|MultivariatePolynomial| |partial| |Sm2PolyType|) + (|RectangularMatrix| |indeterm| |Sm2Rm|) + (|UnivariatePolynomial| |indeterm| |Sm2PolyType|) + (|Vector| |indeterm| |Sm2V|)) + (|Symbol| + (|DistributedMultivariatePolynomial| |indeterm| |Sy2Dmp|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |Sy2NDmp|) + (|MultivariatePolynomial| |indeterm| |Sy2Mp|) + (|OrderedVariableList| |partial| |Sy2OV|) + (|Polynomial| |total| |Sy2P|) + (|UnivariatePolynomial| |indeterm| |Sy2Up|) + (|Variable| |indeterm| |Sy2Var|)) + (|UnivariatePolynomial| + (|DistributedMultivariatePolynomial| |indeterm| |Up2Dmp|) + (|Expression| |indeterm| |Up2Expr|) + (|Factored| |indeterm| |Up2FR|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |domain2NDmp|) + (|MultivariatePolynomial| |indeterm| |Up2Mp|) + (|Polynomial| |indeterm| |Up2P|) + (|SparseUnivariatePolynomial| |indeterm| |Up2SUP|) + (|UnivariatePolynomial| |indeterm| |Up2Up|)) + (|Variable| + (|AlgebraicFunction| |total| |Var2FS|) + (|ContinuedFractionPowerSeries| |indeterm| |Var2OtherPS|) + (|DistributedMultivariatePolynomial| |indeterm| |Var2Dmp|) + (|ElementaryFunction| |total| |Var2FS|) + (|Fraction| |indeterm| |Var2QF|) + (|FunctionalExpression| |total| |Var2FS|) + (|GeneralDistributedMultivariatePolynomial| |indeterm| |Var2Gdmp|) + (|HomogeneousDistributedMultivariatePolynomial| |indeterm| |Var2NDmp|) + (|LiouvillianFunction| |total| |Var2FS|) + (|MultivariatePolynomial| |indeterm| |Var2Mp|) + (|OrderedVariableList| |indeterm| |Var2OV|) + (|Polynomial| |total| |Var2P|) + (|SparseUnivariatePolynomial| |indeterm| |Var2SUP|) + (|Symbol| |total| |Identity|) + (|UnivariatePolynomial| |indeterm| |Var2Up|) + (|UnivariatePowerSeries| |indeterm| |Var2UpS|)) + (|Vector| + (|DirectProduct| |indeterm| V2DP) + (|List| |indeterm| V2L) + (|Matrix| |indeterm| V2M) + (|RectangularMatrix| |indeterm| |V2Rm|) + (|Set| |indeterm| |Agg2L2Agg|) + (|SquareMatrix| |indeterm| |V2Sm|) + (|Stream| |indeterm| |Agg2Agg|)))))) + +;-- this list is too long for the parser, so it has to be split into parts +;-- specifies the commute functions +;-- commute stands for partial commute function +;--SETANDFILEQ($CommuteTable, '( _ +;-- (DistributedMultivariatePolynomial . ( _ +;-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Complex commute commuteMultPol) _ +;-- (MultivariatePolynomial commute commuteMultPol) _ +;-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Polynomial commute commuteMultPol) _ +;-- (Quaternion commute commuteMultPol) _ +;-- (Fraction commute commuteMultPol) _ +;-- (SquareMatrix commute commuteMultPol) _ +;-- (UnivariatePolynomial commute commuteMultPol) _ +;-- )) _ +;-- (Complex . ( _ +;-- (DistributedMultivariatePolynomial commute commuteG2) _ +;-- (MultivariatePolynomial commute commuteG2) _ +;-- (NewDistributedMultivariatePolynomial commute commuteG2) _ +;-- (Polynomial commute commuteG1) _ +;-- (Fraction commute commuteG1) _ +;-- (SquareMatrix commute commuteG2) _ +;-- (UnivariatePolynomial commute commuteG2) _ +;-- )) _ +;-- (MultivariatePolynomial . ( _ +;-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Complex commute commuteMultPol) _ +;-- (MultivariatePolynomial commute commuteMultPol) _ +;-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Polynomial commute commuteMultPol) _ +;-- (Quaternion commute commuteMultPol) _ +;-- (Fraction commute commuteMultPol) _ +;-- (SquareMatrix commute commuteMultPol) _ +;-- (UnivariatePolynomial commute commuteMultPol) _ +;-- )) _ +;-- (Polynomial . ( _ +;-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Complex commute commuteMultPol) _ +;-- (MultivariatePolynomial commute commuteMultPol) _ +;-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +;-- (Polynomial commute commuteMultPol) _ +;-- (Quaternion commute commuteMultPol) _ +;-- (Fraction commute commuteMultPol) _ +;-- (SquareMatrix commute commuteMultPol) _ +;-- (UnivariatePolynomial commute commuteMultPol) _ +;-- )) _ +;-- (Quaternion . ( _ +;-- (DistributedMultivariatePolynomial commute commuteQuat2) _ +;-- (MultivariatePolynomial commute commuteQuat2) _ +;-- (NewDistributedMultivariatePolynomial commute commuteQuat2) _ +;-- (Polynomial commute commuteQuat1) _ +;-- (SquareMatrix commute commuteQuat2) _ +;-- (UnivariatePolynomial commute commuteQuat2) _ +;-- )) _ +;-- (SquareMatrix . ( _ +;-- (DistributedMultivariatePolynomial commute commuteSm2) _ +;-- (Complex commute commuteSm1) _ +;-- (MultivariatePolynomial commute commuteSm2) _ +;-- (NewDistributedMultivariatePolynomial commute commuteSm2) _ +;-- (Polynomial commute commuteSm1) _ +;-- (Quaternion commute commuteSm1) _ +;-- (SparseUnivariatePolynomial commute commuteSm1) _ +;-- (UnivariatePolynomial commute commuteSm2) _ +;-- )) _ +;-- (UnivariatePolynomial . ( _ +;-- (DistributedMultivariatePolynomial commute commuteUp2) _ +;-- (Complex commute commuteUp1) _ +;-- (MultivariatePolynomial commute commuteUp2) _ +;-- (NewDistributedMultivariatePolynomial commute commuteUp2) _ +;-- (Polynomial commute commuteUp1) _ +;-- (Quaternion commute commuteUp1) _ +;-- (Fraction commute commuteUp1) _ +;-- (SparseUnivariatePolynomial commute commuteUp1) _ +;-- (SquareMatrix commute commuteUp2) _ +;-- (UnivariatePolynomial commute commuteUp2) _ +;-- )) _ +;-- )) +;SETANDFILEQ($CommuteTable, '( _ +; (Complex . ( _ +; (DistributedMultivariatePolynomial commute commuteG2) _ +; (MultivariatePolynomial commute commuteG2) _ +; (HomogeneousDistributedMultivariatePolynomial commute commuteG2) _ +; (Polynomial commute commuteG1) _ +; (Fraction commute commuteG1) _ +; (SquareMatrix commute commuteG2) _ +; (UnivariatePolynomial commute commuteG2) _ +; )) _ +; (Polynomial . ( _ +; (Complex commute commuteMultPol) _ +; (MultivariatePolynomial commute commuteMultPol) _ +; (HomogeneousDistributedMultivariatePolynomial commute commuteMultPol)_ +; (Polynomial commute commuteMultPol) _ +; (Quaternion commute commuteMultPol) _ +; (Fraction commute commuteMultPol) _ +; (SquareMatrix commute commuteMultPol) _ +; (UnivariatePolynomial commute commuteMultPol) _ +; )) _ +; (SquareMatrix . ( _ +; (DistributedMultivariatePolynomial commute commuteSm2) _ +; (Complex commute commuteSm1) _ +; (MultivariatePolynomial commute commuteSm2) _ +; (HomogeneousDistributedMultivariatePolynomial commute commuteSm2)_ +; (Polynomial commute commuteSm1) _ +; (Quaternion commute commuteSm1) _ +; (SparseUnivariatePolynomial commute commuteSm1) _ +; (UnivariatePolynomial commute commuteSm2) _ +; )) _ +; )) + +(SETANDFILEQ |$CommuteTable| + (QUOTE ( + (|Complex| + (|DistributedMultivariatePolynomial| |commute| |commuteG2|) + (|MultivariatePolynomial| |commute| |commuteG2|) + (|HomogeneousDistributedMultivariatePolynomial| |commute| |commuteG2|) + (|Polynomial| |commute| |commuteG1|) + (|Fraction| |commute| |commuteG1|) + (|SquareMatrix| |commute| |commuteG2|) + (|UnivariatePolynomial| |commute| |commuteG2|)) + (|Polynomial| + (|Complex| |commute| |commuteMultPol|) + (|MultivariatePolynomial| |commute| |commuteMultPol|) + (|HomogeneousDistributedMultivariatePolynomial| |commute| |commuteMultPol|) + (|Polynomial| |commute| |commuteMultPol|) + (|Quaternion| |commute| |commuteMultPol|) + (|Fraction| |commute| |commuteMultPol|) + (|SquareMatrix| |commute| |commuteMultPol|) + (|UnivariatePolynomial| |commute| |commuteMultPol|)) + (|SquareMatrix| + (|DistributedMultivariatePolynomial| |commute| |commuteSm2|) + (|Complex| |commute| |commuteSm1|) + (|MultivariatePolynomial| |commute| |commuteSm2|) + (|HomogeneousDistributedMultivariatePolynomial| |commute| |commuteSm2|) + (|Polynomial| |commute| |commuteSm1|) + (|Quaternion| |commute| |commuteSm1|) + (|SparseUnivariatePolynomial| |commute| |commuteSm1|) + (|UnivariatePolynomial| |commute| |commuteSm2|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}