diff options
Diffstat (limited to 'src/interp/i-coerfn.boot.pamphlet')
-rw-r--r-- | src/interp/i-coerfn.boot.pamphlet | 2312 |
1 files changed, 0 insertions, 2312 deletions
diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet deleted file mode 100644 index 24f14bf5..00000000 --- a/src/interp/i-coerfn.boot.pamphlet +++ /dev/null @@ -1,2312 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-coerfn.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\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} -<<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. - -@ -<<*>>= -<<license>> - -import '"i-coerce" -)package "BOOT" - -$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(objNewWrap(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} |