diff options
Diffstat (limited to 'src/interp/i-coerfn.boot.pamphlet')
| -rw-r--r-- | src/interp/i-coerfn.boot.pamphlet | 2309 |
1 files changed, 2309 insertions, 0 deletions
diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet new file mode 100644 index 00000000..034067d3 --- /dev/null +++ b/src/interp/i-coerfn.boot.pamphlet @@ -0,0 +1,2309 @@ +\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>> + +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} |