1module bcsf; 2 3% Redistribution and use in source and binary forms, with or without 4% modification, are permitted provided that the following conditions are met: 5% 6% * Redistributions of source code must retain the relevant copyright 7% notice, this list of conditions and the following disclaimer. 8% * Redistributions in binary form must reproduce the above copyright 9% notice, this list of conditions and the following disclaimer in the 10% documentation and/or other materials provided with the distribution. 11% 12% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 13% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 14% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 15% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 16% CONTRIBUTORS 17% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 18% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 19% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 20% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 21% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 22% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 23% POSSIBILITY OF SUCH DAMAGE. 24% 25 26 27COMMENT 28 29 30 ####################### 31 # # 32 # BASE COEFFICIENTS # 33 # # 34 ####################### 35 36 37These base coefficients are standard forms. 38 39A list of REPLACEBY rules may be supplied with the setrules command 40that will be applied in an additional simplification process. 41 42This rules list is a list of s.f. pairs, where car should replace cdr. 43 44END COMMENT; 45 46% Standard is : 47 48!*hardzerotest:=nil; 49 50symbolic operator setrules; 51symbolic procedure setrules m; setrules!* cdr reval m; 52 53symbolic procedure setrules!* m; 54 begin scalar r; r:=ring_names cali!=basering; 55 m:=for each x in m collect 56 if not eqcar(x,'replaceby) then 57 typerr(makelist m,"rules list") 58 else (numr simp second x . numr simp third x); 59 for each x in m do 60 if domainp car x or member(mvar car x,r) then 61 rederr"no substitution for ring variables allowed"; 62 put('cali,'rules,m); 63 return getrules(); 64 end; 65 66symbolic operator getrules; 67symbolic procedure getrules(); 68 makelist for each x in get('cali,'rules) collect 69 list('replaceby,prepf car x,prepf cdr x); 70 71symbolic procedure bc!=simp u; 72 (if r0 then 73 begin scalar r,c; integer i; 74 i:=0; r:=r0; 75 while r and (i<1000) do 76 << c:=qremf(u,caar r); 77 if null car c then r:=cdr r 78 else 79 << u:=addf(multf(car c,cdar r),cdr c); 80 i:=i+1; r:=r0; 81 >>; 82 >>; 83 if (i<1000) then return u 84 else rederr"recursion depth of bc!=simp too high" 85 end 86 else u) where r0:=get('cali,'rules); 87 88symbolic procedure cali_bc_minus!? u; minusf u; 89 90symbolic procedure cali_bc_zero!? u; 91 if (null u or u=0) then t 92 else if !*hardzerotest and pairp u then 93 null bc!=simp numr simp prepf u 94 else nil; 95 96symbolic procedure cali_bc_fi a; if a=0 then nil else a; 97 98symbolic procedure cali_bc_one!? u; (u = 1); 99 100symbolic procedure cali_bc_inv u; 101% Test, whether u is invertible. Return the inverse of u or nil. 102 if (u=1) or (u=-1) then u 103 else begin scalar v; v:=qremf(1,u); 104 if cdr v then return nil else return car v; 105 end; 106 107symbolic procedure cali_bc_neg u; negf u; 108 109symbolic procedure cali_bc_prod (u,v); bc!=simp multf(u,v); 110 111symbolic procedure cali_bc_quot (u,v); 112 (if null cdr w then bc!=simp car w else typerr(v,"denominator")) 113 where w=qremf(u,v); 114 115symbolic procedure cali_bc_sum (u,v); addf(u,v); 116 117symbolic procedure cali_bc_diff(u,v); addf(u,negf v); 118 119symbolic procedure cali_bc_power(u,n); bc!=simp exptf(u,n); 120 121symbolic procedure cali_bc_from_a u; bc!=simp numr simp!* u; 122 123symbolic procedure cali_bc_2a u; prepf u; 124 125symbolic procedure cali_bc_prin u; 126% Prints a base coefficient in infix form 127 ( if domainp u then 128 if dmode!*='!:mod!: then prin2 prepf u 129 else printsf u 130 else << write"("; printsf u; write")" >>) where !*nat=nil; 131 132symbolic procedure cali_bc_divmod(u,v); % Returns quot . rem. 133 qremf(u,v); 134 135symbolic procedure cali_bc_gcd(u,v); gcdf!*(u,v); 136 137symbolic procedure cali_bc_lcm(u,v); 138 car cali_bc_divmod(cali_bc_prod(u,v),cali_bc_gcd(u,v)); 139 140endmodule; % bcsf 141 142end; 143