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