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