1module prep; % Functions for converting canon. forms into prefix forms.
2
3% Author: Anthony C. Hearn.
4
5% Copyright (c) 1987 The RAND Corporation. All rights reserved.
6
7% Redistribution and use in source and binary forms, with or without
8% modification, are permitted provided that the following conditions are met:
9%
10%    * Redistributions of source code must retain the relevant copyright
11%      notice, this list of conditions and the following disclaimer.
12%    * Redistributions in binary form must reproduce the above copyright
13%      notice, this list of conditions and the following disclaimer in the
14%      documentation and/or other materials provided with the distribution.
15%
16% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
17% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
18% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
19% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
20% CONTRIBUTORS
21% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
23% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
25% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
26% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
27% POSSIBILITY OF SUCH DAMAGE.
28%
29
30
31fluid '(!*bool !*intstr);
32
33symbolic procedure prepsqxx u;
34   % This is a top level conversion function.  It is not clear if we
35   % need prepsqxx, prepsqx, prepsq!* and prepsq, but we keep them all
36   % for the time being.
37   negnumberchk prepsqx u;
38
39symbolic procedure negnumberchk u;
40   if eqcar(u,'minus) and numberp cadr u then - cadr u else u;
41
42symbolic procedure prepsqx u;
43   if !*intstr then prepsq!* u else prepsq u;
44
45symbolic procedure prepsq u;
46   if null numr u then 0 else sqform(u,function prepf);
47
48symbolic procedure sqform(u,v);
49   (lambda (x,y); if y=1 then x else list('quotient,x,y))
50      (apply1(v,numr u),apply1(v,denr u));
51
52% For at least a while I am leaving the OLD version around, albeit
53% unused.
54
55symbolic procedure oldprepf u;
56   (if null x then 0 else replus x) where x=oldprepf1(u,nil);
57
58symbolic procedure prepf u;
59  replus1 prepf1a(u, nil);
60
61% This old version of prepf1 seems bad to me in that it keeps using
62% nconc to append segments of the result. Each such call involves
63% traversing the length of the result generated by an inner call to prepf1.
64% In bad cases this leads to costs that grow badly as the number of variable
65% increases.
66
67symbolic procedure oldprepf1(u,v);
68   if null u then nil
69   else if domainp u then list retimes(prepd u . exchk v)
70   else nconc!*(oldprepf1(lc u,if mvar u eq 'k!* then v else lpow u . v),
71                oldprepf1(red u,v));
72
73% prepf1 seems only to be used in this file, and so as soon as it has been
74% performed the result will be passed to replus (and through that to
75% unplus). So it should make good sense to perform the replus/unplus steps
76% as one goes... But I will leave a function prepf1 that behaves exactly as
77% per the original just in case anybody wants it and make my composite
78% of pref1 and replus a new function...
79
80symbolic procedure prepf1(u, v);
81   reversip prepf1_reversed(u, v, nil);
82
83% This code builds up the result in reversed order. It is more explicitly
84% tail-recursive in the CDR direction and avoids not just any twitching about
85% side effects with nconc but potential repeated scannning of data.
86
87symbolic procedure prepf1_reversed(u, v, r);
88  begin
89top:
90    if null u then return r
91    else if domainp u then return (retimes(prepd u . exchk v) . r);
92    r := prepf1_reversed(lc u,
93                         if mvar u eq 'k!* then v else lpow u . v,
94                         r);
95    u := red u;
96    go to top
97  end;
98
99% prepf1a will be like prepf1 except that it performs any "unplus"
100% operations that might be useful. It is the version that will actually go
101% into service. If it proves sensible over a while then the earlier code
102% will be removed totally. Note that this version will do what I believe to
103% be correct rather than what the previous version of the code did!
104
105symbolic procedure prepf1a(u, v);
106  reversip prepf1a_reversed(u, v, nil);
107
108symbolic procedure prepf1a_reversed(u, v, r);
109  begin
110top:
111    if null u then return r
112    else if domainp u then return
113       begin
114          scalar z;
115          z := retimes(prepd u . exchk v);
116% I will note that an embedded (plus P Q) or (difference P Q) can arise from
117% the conversion of a domain element in the case of complex values, so without
118% the top line (x + (i+1)) might end up as
119%    (plus x (plus i 1)),
120% while I adjust it here to be (plus x i 1). That seems reasonable.
121% Similarly (x + (-1-i)) might end up as
122%    (plus x (difference (minus 1) i))
123% and is adjusted to (plus (minus 1) (minus i).
124          if eqcar(z, 'plus) then <<
125             for each y in cdr z do r := y . r >>
126	  else if eqcar(z, 'difference) then <<
127	     r := cadr z . r; r := {'minus,caddr z} . r >>
128          else r := z . r;
129          return r
130       end;
131    r := prepf1a_reversed(lc u,
132                          if mvar u eq 'k!* then v else lpow u . v,
133                          r);
134    u := red u;
135    go to top
136  end;
137
138symbolic procedure prepd u;
139   if atom u then if u<0 then list('minus,-u) else u
140    else if apply1(get(car u,'minusp),u)
141%    then list('minus,prepd1 !:minus u)
142     then (if null x then 0 else list('minus,x))
143          where x=prepd1 !:minus u
144%   else if !:onep u then 1
145    else apply1(get(car u,'prepfn),u);
146
147symbolic procedure prepd1 u;
148   if atom u then u else apply1(get(car u,'prepfn),u);
149
150% symbolic procedure exchk u;
151%    begin scalar z;
152%       for each j in u do
153%          if cdr j=1
154%            then if eqcar(car j,'expt) and caddar j = '(quotient 1 2)
155%                    then z := list('sqrt,cadar j) .z
156%                   else z := sqchk car j . z
157%            else z := list('expt,sqchk car j,cdr j) . z;
158%       return z
159%   end;
160
161symbolic procedure exchk u; exchk1(u,nil,nil,nil);
162
163symbolic procedure exchk1(u,v,w,x);
164   % checks forms for kernels in EXPT. U is list of powers.  V is used
165   % to build up the final answer. W is an association list of
166   % previous non-constant (non foldable) EXPT's, X is an association
167   % list of constant (foldable) EXPT arguments.
168   if null u then exchk2(append(x,w),v)
169    else if eqcar(caar u,'expt)
170     then begin scalar y,z;
171            y := simpexpon list('times,cdar u,caddar car u);
172            if numberp cadaar u   % constant argument
173              then <<z := assoc2(y,x);
174                     if z then rplaca(z,car z*cadaar u)
175                      else x := (cadaar u . y) . x>>
176             else <<z := assoc(cadaar u,w);
177                    if z then rplacd(z,addsq(y,cdr z))
178                     else w := (cadaar u . y) . w>>;
179            return exchk1(cdr u,v,w,x)
180        end
181    else if cdar u=1 then exchk1(cdr u,sqchk caar u . v,w,x)
182    else exchk1(cdr u,list('expt,sqchk caar u,cdar u) . v,w,x);
183
184symbolic procedure exchk2(u,v);
185   if null u then v
186    else exchk2(cdr u,
187%               ((if eqcar(x,'quotient) and caddr x = 2
188%                  then if cadr x = 1 then list('sqrt,caar u)
189%                        else list('expt,list('sqrt,caar u),cadr x)
190                ((if x=1 then caar u
191                   else if !*nosqrts then list('expt,caar u,x)
192                   else if x = '(quotient 1 2) then list('sqrt,caar u)
193                   else if x=0.5 then list('sqrt,caar u)
194                   else list('expt,caar u,x)) where x = prepsqx cdar u)
195                . v);
196
197symbolic procedure assoc2(u,v);
198   % Finds key U in second position of terms of V, or returns NIL.
199   if null v then nil
200    else if u = cdar v then car v
201    else assoc2(u,cdr v);
202
203symbolic procedure replus u;
204   if null u then 0
205    else if atom u then u
206    else if null cdr u then car u
207    else 'plus . unplus u;
208
209% replus1 is like replus except that it expects that the list of items
210% it is given do not contain "plus" objects... except possibly one that
211% is used as a sort of marker.
212
213symbolic procedure replus1 u;
214   if null u then 0
215    else if atom u or (eqcar(u, 'plus) and cdr u) then u
216    else if null cdr u then car u
217    else 'plus . u;
218
219symbolic procedure unplus u;
220   if atom u then u
221   else if car u = 'plus then unplus cdr u
222   else if atom car u or not eqcar(car u,'plus)
223      then (car u) . unplus cdr u
224   else append(cdar u,unplus cdr u);
225
226% symbolic procedure retimes u;
227%    % U is a list of prefix expressions. Value is prefix form for the
228%    % product of these;
229%    begin scalar bool,x;
230%       for each j in u do
231%         <<if j=1 then nil     % ONEP
232%             else if eqcar(j,'minus)
233%              then <<bool := not bool;
234%                     if cadr j neq 1 then x := cadr j . x>>     % ONEP
235%             else if numberp j and minusp j
236%              then <<bool := not bool;
237%                    if j neq -1 then x := (-j) . x>>
238%             else x := j . x>>;
239%        x := if null x then 1
240%                else if cdr x then 'times . reverse x else car x;
241%        return if bool then list('minus,x) else x
242%   end;
243
244symbolic procedure retimes u;
245   begin scalar !*bool;
246      u := retimes1 u;
247      u := if null u then 1
248            else if cdr u then 'times . u
249            else car u;
250      return if !*bool then list('minus,u) else u
251   end;
252
253symbolic procedure retimes1 u;
254   if null u then nil
255    else if car u = 1 then retimes1 cdr u
256    else if minusp car u
257     then <<!*bool := not !*bool; retimes1((-car u) . cdr u)>>
258    else if atom car u then car u . retimes1 cdr u
259    else if caar u eq 'minus
260     then <<!*bool := not !*bool; retimes1(cadar u . cdr u)>>
261    else if caar u eq 'times then retimes1 append(cdar u,cdr u)
262    else car u . retimes1 cdr u;
263
264symbolic procedure sqchk u;
265   if atom u then u
266    else (if x then apply1(x,u) else if atom car u then u else prepf u)
267          where x=get(car u,'prepfn2);
268
269put('!*sq,'prepfn2,'prepcadr);
270
271put('expt,'prepfn2,'prepexpt);
272
273symbolic procedure prepcadr u; prepsq cadr u;
274
275symbolic procedure prepexpt u; if caddr u=1 then cadr u else u;
276
277% When I enable this then "!*hold" is removed on the way towawards printing.
278% This may generally be a good thing since it causes any necessary extra
279% sets of parens to get inserted. When !*hold is removed that way there
280% is then no cause to need a 'prifn on !*hold - but I leave that present
281% for when anybody has gone "off prephold"... the flexibility here is
282% provided because the "hold" capability is at present an experiment.
283
284put('!*hold, 'prepfn2, 'prephold);
285
286switch prephold;
287!*prephold := t;
288
289symbolic procedure prephold u;
290   if (not !*prephold) or atom u then u
291   else if eqcar(u, '!*hold) then prephold cadr u
292   else if eqcar(u, '!*sq) then prepsq cadr u
293   else prephold car u . prephold cdr u;
294
295endmodule;
296
297end;
298