1module codad1;  % Description of some procedures.
2
3% ------------------------------------------------------------------- ;
4% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
5%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
6% Authors :   J.A. van Hulzen, B.J.A. Hulshof, W.N. Borst.            ;
7% ------------------------------------------------------------------- ;
8
9% Redistribution and use in source and binary forms, with or without
10% modification, are permitted provided that the following conditions are met:
11%
12%    * Redistributions of source code must retain the relevant copyright
13%      notice, this list of conditions and the following disclaimer.
14%    * Redistributions in binary form must reproduce the above copyright
15%      notice, this list of conditions and the following disclaimer in the
16%      documentation and/or other materials provided with the distribution.
17%
18% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
20% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
21% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
22% CONTRIBUTORS
23% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29% POSSIBILITY OF SUCH DAMAGE.
30%
31
32
33symbolic$
34
35% ------------------------------------------------------------------- ;
36% The module CODAD1 contains the description of the procedures        ;
37% IMPROVELAYOUT (part 1), TCHSCHEME (part 2) and CODFAC (part 3),     ;
38% which are used in the procedure OPTIMIZELOOP (see the module CODCTL);
39% to complete the effect of an application of EXTBRSEA (see the module;
40% CODOPT). Application of each of these routines is completed by re-  ;
41% turning a Boolean value, which is used to decide if further optimi- ;
42% zation is still profitable.                                         ;
43% The Smacro's Find!+Var and Find!*Var form service facilities, needed;
44% at different places in this module. These Smacro's define an applic-;
45% ation of the procedure GetCind.                                     ;
46% ------------------------------------------------------------------- ;
47
48% ------------------------------------------------------------------- ;
49% Global identifiers needed in this module are:                       ;
50% ------------------------------------------------------------------- ;
51
52global '(rowmin rowmax kvarlst codbexl!*);
53
54% ------------------------------------------------------------------- ;
55% The meaning of these globals is given in the module CODMAT.         ;
56% ------------------------------------------------------------------- ;
57
58symbolic procedure getcind(var,varlst,op,fa,iv);
59% ------------------------------------------------------------------- ;
60% The purpose of the procedure GetCind is to create a column in CODMAT;
61% which will be associated with the variable Var if this variable does;
62% not yet belong to the set Varlst,i.e.does not yet play a role in the;
63% corresponding PLUS- or TIMES setting (known by the value of Op).Once;
64% the column exists (either created or already available), its Zstrt  ;
65% is modified by inserting the Z-element (Fa,IV) in it. Finally the   ;
66% corresponding Z-element for the father-scope_row, i.e. (Y,IV) is returned.;
67% ------------------------------------------------------------------- ;
68begin scalar y,z;
69  if null(y:=get(var,varlst))
70  then
71  <<y:=rowmin:=rowmin-1;
72    put(var,varlst,y);
73    setrow(y,op,var,nil,nil)
74  >>;
75  scope_setzstrt(y,inszzzn(z:=mkzel(fa,iv),scope_zstrt y));
76  return mkzel(y,val z)
77end;
78
79symbolic inline procedure find!+var(var,fa,iv);
80getcind(var,'varlst!+,'plus,fa,iv);
81
82symbolic inline procedure find!*var(var,fa,iv);
83getcind(var,'varlst!*,'times,fa,iv);
84
85% ------------------------------------------------------------------- ;
86% PART 1 : LAYOUT IMPROVEMENT                                         ;
87% ------------------------------------------------------------------- ;
88
89symbolic procedure improvelayout;
90% ------------------------------------------------------------------- ;
91% During optimization, and thus during common subexpression generation;
92% it might happen that a (sub)expression is reduced to a single varia-;
93% ble, leading to output containing the assignment statements :       ;
94%  b:=b-thing;                                                        ;
95%  ......                                                             ;
96%  a:=b;                                                              ;
97% This redundancy can be removed by replacing all occurrences of b by ;
98% a, by replacing b:=b-thing by a:=b=thing and by removing a:=b. Here ;
99% we assume a,b to be only cse-names.                                 ;
100% ------------------------------------------------------------------- ;
101begin scalar var,b;
102  for x:=0:rowmax do
103  if not (numberp(var:=scope_farvar x)
104          or
105          pairp(var)
106          or
107          (member(x,codbexl!*)
108           and
109           (get(var,'nex) or
110            not(flagp(var, 'newsym)) or
111            get(var,'alias)
112            % or not(get(var,'alias)) % JB 10/3/94
113            % finds no cse in p.e. cos(e^s6),sin(e^s6)
114           )))
115     and testononeel(var,x) then b:=t;
116  % ----------------------------------------------------------------- ;
117  % If B=T redundancy was removed from CODMAT, but not necessarily    ;
118  % from Kvarlst, the list of pairs of kernels and names associated   ;
119  % with them. ImproveKvarlst is applied to achieve this.             ;
120  % ----------------------------------------------------------------- ;
121  if b then improvekvarlst();
122  return b
123end;
124
125symbolic procedure testononeel(var,x);
126% ------------------------------------------------------------------- ;
127% Row X,having Var as its assigned variable, and defining some expres-;
128% sion, through its Zstrt, Chrow and ExpCof, is analysed.             ;
129% If this scope_row defines a redundant assignment statement the above indi-;
130% cated actions are performed.                                        ;
131% ------------------------------------------------------------------- ;
132begin
133  scalar scol,srow,el,signiv,signec,zz,ordrx,negcof,trow,
134                                           oldvar,b,el1,scof,bop!+,lhs;
135  if (zz:=scope_zstrt x) and null(cdr zz) and null(scope_chrow x) and
136      !:onep(dm!-abs(signiv:=ival(el:=car zz))) and
137      !:onep(signec:=scope_expcof(x))
138  %   !:onep(dm!-abs(signec:=scope_expcof(x)))
139  %   This could mean a:=b^(-1), which is rather tricky to update
140  %   when b is used in other plusrows.  JB. 7-5-93.
141  then
142   << % ------------------------------------------------------------- ;
143      % Row(X) defines a Zstreet, consisting of one Z-element. The    ;
144      % variable-name, associated with this element is stored in the  ;
145      % FarVar-field of the column, whose index is in the Yind-part of;
146      % this Z-element,i.e. Oldvar:=FarVar(SCol),the b mentioned above;
147      % The IVal-value of this element, an exponent or a coefficient, ;
148      % is 1 or -1 and the ExpCof-value, a coefficient or an exponent,;
149      % is also 1 or -1. Realistic possibilities are of course only   ;
150      % 1*Oldvar^1 or -1*Oldvar^1 (i.e. 1*b^1 or -1*b^1).             ;
151      % ------------------------------------------------------------- ;
152      scol:=yind el;
153      oldvar:=scope_farvar(scol);
154      if srow:=get(oldvar,'rowindex)
155       then b:=t
156       else
157        if assoc(oldvar,kvarlst) and
158           !:onep(signiv) and !:onep(signec) and
159           not member(oldvar,codbexl!*)
160         then b:=t;
161      % ------------------------------------------------------------- ;
162      % So B=T if either Oldvar has its own defining scope_row, whose index ;
163      % is stored as value of the indicator Rowindex, i.e. if Oldvar  ;
164      % defines a cse, or if Oldvar is the name of a kernel, stored in;
165      % Kvarlst, as cdr-part of the pair having Oldvar as its car-part;
166      % ------------------------------------------------------------- ;
167       if b
168        then
169         << % ------------------------------------------------------- ;
170            % We start replacing all occurrences of Oldvar by Var, in ;
171            % both the PLUS- and the TIMES-part of CODMAT, by applying;
172            % the function TShrinkCol. In addition all eventually exis;
173            % ting occurences of Oldvar in Kvarlst have to replaced as;
174            % well by Var(,the a mentioned above).                    ;
175            % ------------------------------------------------------- ;
176            scope_setzstrt(scol,delyzz(x,scope_zstrt scol));
177            tshrinkcol(oldvar,var,'varlst!+);
178            tshrinkcol(oldvar,var,'varlst!*);
179            if ((scope_opval(x) eq 'plus) and !:onep(dm!-minus signiv))
180                or
181               ((scope_opval(x) eq 'times) and !:onep(dm!-minus signec))
182             then << var:=list('minus,var);
183                     kvarlst:=subst(var,oldvar,kvarlst);
184                     preprefixlist:=subst(var,oldvar,preprefixlist);
185                     var:=cadr var;
186                     negcof:=-1
187                  >>
188             else << kvarlst:=subst(var,oldvar,kvarlst);
189                     preprefixlist:=subst(var,oldvar,preprefixlist);
190                     negcof:=1
191                  >>;
192            if (lhs:=get(oldvar,'inlhs))
193               then
194               << put(lhs,'nex,subst(var,oldvar,get(lhs,'nex)));
195                  remprop(oldvar,'inlhs)>>;
196            if (lhs:=get(oldvar,'inalias))
197               then
198               << updatealiases(oldvar,var);
199                  %put(lhs,'alias,subst(var,oldvar,get(lhs,'alias)));
200                  remprop(oldvar,'inalias)>>;
201            if srow
202            then
203             << % --------------------------------------------------- ;
204                % Oldvar is the name of a cse, defined through the scope_row;
205                % index Srow. So this cse-definition has to be assign-;
206                % ed to Var as new value and the Srow itself has to be;
207                % made redundant. The Ordr-field of Var has to be chan;
208                % ged to be able to remain guaranteeing a correct out-;
209                % put sequence.                                       ;
210                % --------------------------------------------------- ;
211                ordrx:=ordr(x);
212                bop!+:=scope_opval(srow) eq 'plus;
213                if bop!+ then scof:=scope_expcof srow
214                         else scof:=dm!-times(negcof,scope_expcof(srow));
215                setrow(x,scope_opval srow,var,list(scope_chrow srow,scof),
216                                                           scope_zstrt srow);
217                setordr(x,append(ordr srow,remordr(srow,ordrx)));
218                if !:onep(dm!-minus signiv)
219                 then
220                  <<foreach z in scope_zstrt(scol) do
221                       setival(z,dm!-minus ival(z));
222                    foreach ch in scope_chrow(x) do
223                       scope_setexpcof(ch,dm!-minus scope_expcof(ch));
224                    if trow:=get(var,'varlst!*) then
225                    foreach el in scope_zstrt(trow) do
226                       scope_setexpcof(xind el, dm!-minus scope_expcof(xind el));
227                  >>;
228                foreach ch in scope_chrow(srow) do scope_setfarvar(ch,x);
229                clearrow(srow);
230                setordr(srow,nil);
231                codbexl!*:=subst(x,srow,codbexl!*);
232                foreach z in scope_zstrt(x) do
233                 <<if bop!+ then setival(z,dm!-times(signiv,ival(z)));
234                   scope_setzstrt(yind z,inszzz(mkzel(x,val z),
235                                            delyzz(srow,scope_zstrt yind z)))
236                 >>;
237                for sindex:=0:rowmax
238                 do setordr(sindex,subst(x,srow,ordr sindex));
239                testononeel(var,x)
240             >>
241            else
242             << % --------------------------------------------------- ;
243                % Oldvar is the system-generated name of a kernel.    ;
244                % The internal administration is modified, as to pro- ;
245                % vide Var with its new role.                         ;
246                % As a side-effect the index X of the kernel defining ;
247                % scope_row is replaced in CodBexl!* by the name Var, if oc-;
248                % curring of course, i.e. if this function definition ;
249                % was given at toplevel on input.                     ;
250                % This information is used in ImproveKvarlst.         ;
251                % --------------------------------------------------- ;
252                codbexl!*:=subst(var,x,codbexl!*);
253                ordrx:=remordr(oldvar,ordr x);
254                clearrow(x);
255                setordr(x,nil);
256                for sindex:=0:rowmax do
257                 setordr(sindex,
258                              updordr(ordr sindex,var,oldvar,ordrx,x));
259                improvekvarlst()
260             >>;
261         >>
262   >>;
263  return b;
264end$
265
266symbolic procedure remordr(x,olst);
267% ------------------------------------------------------------------- ;
268% Olst is the value of the Ordr-field of a scope_row of CODMAT. Olst defines;
269% in which order the cse's, occurring in the (sub)expression, whose   ;
270% description starts in this scope_row, have to be printed ahead of this    ;
271% (sub)expression. It is a list of kernelnames and/or indices of rows ;
272% where cse-descriptions start.                                       ;
273% RemOrdr returns Olst after removal of X, if occcurring.             ;
274% ------------------------------------------------------------------- ;
275if null(olst)
276then olst
277else
278  if car(olst)=x
279  then remordr(x,cdr olst)
280  else car(olst).remordr(x,cdr olst);
281
282symbolic procedure updordr(olst,var,oldvar,ordrx,x);
283% ------------------------------------------------------------------- ;
284% Olst is described in RemOrdr. OrdrX is the Olst of scope_row X after remo-;
285% val Oldvar from it. Row X defines Var:=Oldvar. Oldvar, a kernelname,;
286% is replaced by Var in Olst. If X is occurring in Olst OrdrX have to ;
287% be inserted in Olst. The thus modified version of Olst is returned. ;
288% ------------------------------------------------------------------- ;
289if null(olst)
290then olst
291else
292  if car(olst) eq oldvar
293  then var.updordr(cdr olst,var,oldvar,ordrx,x)
294  else
295    if car(olst)=x
296    then append(var.ordrx,updordr(cdr olst,var,oldvar,ordrx,x))
297    else car(olst).updordr(cdr olst,var,oldvar,ordrx,x);
298
299symbolic procedure improvekvarlst;
300% ------------------------------------------------------------------- ;
301% Kvarlst, a list of pairs (name . function definition) is improved,if;
302% necessary. This is only required if in the list CodBexl!* occuring  ;
303% names are not yet used in Kvarlst. Hence adequate rewriting of      ;
304% b:=sin(x)                                                           ;
305% ........                                                            ;
306% a:=b                                                                ;
307% into                                                                ;
308% a:=sin(x) is needed,i.e. replacement of (b . sin(x)) by (a . sin(x));
309% in Kvarlst.                                                         ;
310% ------------------------------------------------------------------- ;
311begin scalar invkvl,newkvl,x,y,kv,lkvl,cd,cd1;
312  newkvl:=kvarlst;
313  repeat
314  <<lkvl:=kvarlst:=newkvl;
315    invkvl:=newkvl:=nil;
316    while lkvl do
317    <<kv:=car(lkvl);
318      lkvl:=cdr(lkvl);
319      cd1:=member(car kv,codbexl!*);
320      x:=assoc(cdr kv,invkvl);
321      if x
322      then cd:=(cd1 and member(cdr x,codbexl!*));
323      if x and not cd
324      then
325      <<kv:=car(kv);
326        x:=cdr(x);
327        if cd1
328        then <<y:=x;
329               x:=kv;
330               kv:=y>>;
331        tshrinkcol(kv,x,'varlst!+);
332        tshrinkcol(kv,x,'varlst!*);
333        for rindx:=0:rowmax do
334        setordr(rindx,subst(x,kv,ordr rindx));
335        newkvl:=subst(x,kv,newkvl);
336        invkvl:=subst(x,kv,invkvl);
337        lkvl:=subst(x,kv,lkvl)
338      >>
339      else
340      <<invkvl:=(cdr(kv).car(kv)).invkvl;
341        newkvl:=kv.newkvl
342      >>
343    >>
344  >>
345  until length(kvarlst)=length(newkvl);
346end;
347
348symbolic procedure tshrinkcol(oldvar,var,varlst);
349% ------------------------------------------------------------------- ;
350% All occurrences of Oldvar have to be replaced by Var. This is done  ;
351% by replacing the PLUS and TIMES column-indices of Oldvar by the cor-;
352% responding indices of Var. Y1 and Y2 get the value of the Oldvar-   ;
353% index and the Var-index, respectively. As a side-effect, all additi-;
354% onal information, stored in the property-list of Oldvar is removed. ;
355% ------------------------------------------------------------------- ;
356begin scalar y1,y2;
357  if get(oldvar,'inalias)
358     then updatealiases(oldvar, var);
359  if y1:=get(oldvar,varlst)
360  then
361  <<if y2:=get(var,varlst)
362    then
363    <<foreach z in scope_zstrt(y1) do
364      <<scope_setzstrt(y2,inszzzn(z,scope_zstrt y2));
365        scope_setzstrt(xind z,inszzzr(mkzel(y2,val z),
366                 delyzz(y1,scope_zstrt xind z)))
367      >>;
368      clearrow(y1)
369    >>
370    else
371    <<scope_setfarvar(y1,var);
372      put(var,varlst,y1)
373    >>;
374    remprop(oldvar,varlst)
375  >>;
376  remprop(oldvar,'npcdvar);
377  remprop(oldvar,'nvarlst);
378end;
379
380symbolic procedure updatealiases(old, new);
381% ----------------------------------------------------------------- ;
382% Variable old is going to be replaced  by new.
383% We hav eto ensure that the alias-linking remains
384% consistent. This means that the following has to
385% be updated:
386% Occurrence-info of index-alias:
387%           new.inalias <- old.inalias
388% The aliased vars have to be informed that the alias
389% is performed by a new variable:
390%           alias <- new|old
391%           original.finalalias <- new|old
392%     where A|B means : replace B by A.
393% ----------------------------------------------------------------- ;
394begin scalar original;
395  put(new,'inalias,get(old,'inalias));
396  flag(list new,'aliasnewsym);
397  foreach el in get(old,'inalias) do
398     <<put(el,'alias,subst(new,old,(original:=get(el,'alias))));
399       if atom original
400         then put(original,'finalalias,
401                    subst(new, old, get(original,'finalalias)))
402         else put(car original,'finalalias,
403                    subst(new,old,get(car original,'finalalias)))
404     >>;
405end$
406
407% ------------------------------------------------------------------- ;
408% PART 2 : INFORMATION MIGRATION                                      ;
409% ------------------------------------------------------------------- ;
410symbolic procedure tchscheme;
411% ------------------------------------------------------------------- ;
412% A product(sum) -reduced to a single element- can eventually be remo-;
413% ved from the TIMES(PLUS)-part of CODMAT. If certain conditions are  ;
414% fulfilled (defined by the function TransferRow) it is transferred to;
415% the Zstreet of its father PLUS(TIMES)-scope_row and its index is removed  ;
416% from the ChRow of its father.                                       ;
417% T is returned if atleast one such a migration event takes place.    ;
418% NIL is returned otherwise.                                          ;
419% ------------------------------------------------------------------- ;
420begin scalar zz,b;
421  for x:=0:rowmax do
422  if not(scope_farvar(x)=-1)
423     and (zz:=scope_zstrt x) and null(cdr zz) and transferrow(x,ival car zz)
424   then <<chscheme(x,car zz); b:=t>>;
425  return b;
426end;
427
428symbolic procedure chscheme(x,z);
429% ------------------------------------------------------------------- ;
430% The Z-element Z, the only element the Zstreet of scope_row(X) has, has to ;
431% be transferred from the PLUS(TIMES)-part to the TIMES(PLUS)-part of ;
432% CODMAT.                                                             ;
433% ------------------------------------------------------------------- ;
434begin scalar fa,opv,cof,exp;
435    scope_setzstrt(yind z,delyzz(x,scope_zstrt yind z));
436    scope_setzstrt(x,nil);
437    if scope_opval(x) eq 'plus
438    then <<exp:=1; cof:=ival z>>
439    else <<exp:=ival z; cof:=1>>;
440 l1: fa:=scope_farvar(x);
441     opv:=scope_opval(x);
442     if opv eq 'plus
443     then
444     <<cof:=dm!-expt(cof,scope_expcof(x));
445       exp:=dm!-times(scope_expcof(x),exp);
446       chdel(fa,x);
447       clearrow(x);
448       if null(scope_zstrt fa) and transferrow(fa,exp)
449       then <<x:=fa; goto l1>>
450     >>
451     else
452     << if opv eq 'times
453        then
454        <<cof:=dm!-times(cof,scope_expcof(x));
455          chdel(fa,x);
456          clearrow(x);
457          if null(scope_zstrt fa) and transferrow(fa,cof)
458          then <<x:=fa; goto l1>>
459        >>
460     >>;
461     updfa(fa,exp,cof,z)
462end;
463
464symbolic procedure updfa(fa,exp,cof,z);
465% ------------------------------------------------------------------- ;
466%  FA is the index of the father-scope_row of the Z-element Z,which has to  ;
467% be incorporated in the Zstreet of this scope_row. Its exponent is Exp and ;
468% its coefficient is Cof, both computed in its calling function       ;
469% ChScheme.                                                           ;
470% ------------------------------------------------------------------- ;
471if scope_opval(fa) eq 'plus
472then scope_setzstrt(fa,inszzzr(find!+var(scope_farvar yind z,fa,cof),scope_zstrt fa))
473else
474<<scope_setzstrt(fa,inszzzr(find!*var(scope_farvar yind z,fa,exp),scope_zstrt fa));
475  scope_setexpcof(fa,dm!-times(cof,scope_expcof(fa)))
476>>;
477
478symbolic procedure transferrow(x,iv);
479% ------------------------------------------------------------------- ;
480% IV is the Ivalue of the Z-element, oreming the Zstreet of scope_row X.    ;
481% This element can possibly be transferred.                           ;
482% T is returned if this element can be transferred. NIL is returned   ;
483% otherwise.                                                          ;
484% ------------------------------------------------------------------- ;
485if scope_opval(x) eq 'plus
486 then transferrow1(x) and scope_opval(scope_farvar x) eq 'times
487 else transferrow1(x) and transferrow2(x,iv);
488
489symbolic procedure transferrow1(x);
490% ------------------------------------------------------------------- ;
491% T is returned if scope_row(X) defines a primitive expression (no children);
492% which is part of a larger expression, i.e. scope_row(X) defines a child-  ;
493% expression.                                                         ;
494% ------------------------------------------------------------------- ;
495null(scope_chrow x) and numberp(scope_farvar x);
496
497symbolic procedure transferrow2(x,iv);
498% ------------------------------------------------------------------- ;
499% Row(X) defines a product of the form ExpCof(X)*(a variable) ^ IV,   ;
500% which is part of a sum.                                             ;
501% X is temporarily removed from the list of its fathers children when ;
502% computing B, the return-value.                                      ;
503% B=T if the father-scope_row defines a sum and if either the exponent IV=1 ;
504% or if the father-Zstreet is empty (no primitive terms) and the fa-  ;
505% ther itself can be transferred, i.e. if ExpCof(X)*(a variable) ^ (IV;
506% *ExpCof(Fa)) can be incorporated in the Zstreet of the grandfather- ;
507% scope_row (,which again defines a product).                               ;
508% ------------------------------------------------------------------- ;
509begin scalar fa,b;
510  fa:=scope_farvar(x);
511  chdel(fa,x);
512  b:=scope_opval(fa) eq 'plus and (iv=1 or (null(scope_zstrt fa) and
513                            transferrow(fa,iv*scope_expcof(fa))));
514  scope_setchrow(fa,x.scope_chrow(fa));
515  return b;
516end;
517
518% ------------------------------------------------------------------- ;
519% PART 3 : APPLICATION OF THE DISTRIBUTIVE LAW.                       ;
520% ------------------------------------------------------------------- ;
521% An expression of the form a*b + a*c + d is distributed over 3 rows  ;
522% of CODMAT : One to store the sum structure, i.e. to store the pp of ;
523% the sum, being d, in a Zstrt and 2 others to store the composite    ;
524% terms a*b and a*c as monomials. The indices of the latter rows are  ;
525% also stored in the list Chrow, associated with the sum-scope_row.         ;
526% In addition 4 columns are introduced. One to store the 2 occurrences;
527% of a and 3 others to store the information about b,c and d. The a,b ;
528% and c column belong to the set of TIMES-columns, i.e. a,b and c are ;
529% elements of the list Varlst!* (see the module CODMAT). Similarly the;
530% d belongs to Varlst!+. If this sum is remodelled to obtain a*(b + c);
531% + d changes have to be made in the CODMAT-structure:                ;
532% Now 2 sum-rows are needed and only 1 product-scope_row. Hence the Chrow-  ;
533% information of the original sum-scope_row has to be changed and the 2 pro-;
534% duct-rows have to be removed and replaced by one new scope_row, defining  ;
535% the Zstrt for a and the Chrow to find the description of b + c back.;
536% In addition the column-information for all 4 columns has to be reset;
537% This is a simple example. In general more complicated situations can;
538% be expected. An expression like a*b + a*sin(c) + d requires 4 rows, ;
539% for instance . A CODFAC-application always follows a ExtBrsea-execu-;
540% tion. This implies that potential common factors, defined through *-;
541% col's always have an exponent-value = 1. A common factor like a^3 is;
542% always replaced by a cse (via an appl. of Expand- and Shrinkprod),  ;
543% before the procedure CODFAC is applied. Hence atmost 1 exponent in a;
544% column is not equal 1.                                              ;
545% ------------------------------------------------------------------- ;
546
547symbolic procedure codfac;
548% ------------------------------------------------------------------- ;
549% An application of the procedure CodFac results in an exhaustive all-;
550% level application of the distributive law on the present structure  ;
551% of the set of input-expressions, as reflected by the present version;
552% of CODMAT.                                                          ;
553% If any application of the distributive law proves to be possible the;
554% value T is returned.This is an indication for the calling routine   ;
555% OptimizeLoop that an additional application of ExtBrsea might be    ;
556% profitable.                                                         ;
557% If such an application is not possible the value Nil is returned.   ;
558% ------------------------------------------------------------------- ;
559begin scalar b,lxx;
560  for y:=rowmin:(-1) do
561   % ---------------------------------------------------------------- ;
562   % The Zstrts of all *-columns, which are usable (because their Far-;
563   % Var-field contains a Var-name), are examined by applying the pro-;
564   % cedure SameFar. If this application leads to a non empty list LXX;
565   % with information, needed to be able to apply the distributive law;
566   % the local variable B is set T, possibly the value to be returned.;
567   % B gets the initial value Nil, by declaration.                    ;
568   % ---------------------------------------------------------------- ;
569   if not (scope_farvar(y)=-1 or scope_farvar(y)=-2) and
570                                scope_opval(y) eq 'times and (lxx:=samefar y)
571    then
572     <<b:=t;
573       foreach el in lxx do commonfac(y,el)
574     >>;
575  return b
576end;
577
578symbolic procedure samefar(y);
579% ------------------------------------------------------------------- ;
580% Y is the index of a TIMES-column. The procedure SameFar is designed ;
581% to allow to find and return a list Flst consisting of pairs, formed ;
582% by a father-index and a sub-Zstrt of the Zstrt(Y), consisting of Z's;
583% such that Farvar(Xind Z) = Car Flst, i.e. the Xind(Z)-rows define   ;
584% (composite) productterms of the same sum, which contain the variable;
585% corresponding with column Y as factor in their primitive part.      ;
586% ------------------------------------------------------------------- ;
587begin scalar flst,s,far;
588  foreach z in scope_zstrt(y) do
589   if numberp(far:=scope_farvar xind z) and scope_opval(far) eq 'plus
590    then
591     if s:=assoc(far,flst)
592      then rplacd(s,inszzz(z,cdr(s)))
593      else flst:=(far.inszzz(z,s)).flst;
594  return
595    foreach el in flst conc
596    if cddr(el)
597    then list(el)
598    else nil
599end;
600
601symbolic procedure commonfac(y,xx);
602% ------------------------------------------------------------------- ;
603% Y is the index of a TIMES-column and XX an element of LXX, made with;
604% SameFar(Y), i.e. a pair consisting of the index Far of a father-sum ;
605% scope_row and a sub-Zstrt,consisting of Z-elements, defining factors in   ;
606% productterms of this father-sum.                                    ;
607% These factors are defined by Z-elements (Y.exponent). Atmost one of ;
608% these exponents is greater than 1.                                  ;
609% The purpose of CommonFac is to factor out this element,i.e. to remo-;
610% ve a Z-element (Y.1) from the Zstrts of the children and also its   ;
611% corresponding occurrences from ZZ3 = Zstrt(Y), to combine the remai-;
612% ning sum-information in a new PLUS-scope_row, with index Nsum, and to cre-;
613% ate a TIMES-scope_row, with index Nprod, defining the product of the sum, ;
614% given by the scope_row Nsum, and the variable corresponding with column Y.;
615% ZZ2 and CH2 are used to (re)structure information, by allowing to   ;
616% combine the remaining portions of the child-rows.The father (with   ;
617% index Far) is defined by a Zstrt (its primitive part) and by CH1 =  ;
618% Chrow (its composite part). ZZ4 and CH4 are used to identify the    ;
619% Zstrts of the children after removal of a (Y.1)-element and the     ;
620% Chrow's,respectively.If exponent>1 in (Y.exponent) the Zstrt has to ;
621% be modified to obtain ZZ4, instead of a simple removal of (Y.1) from;
622% from Zstrt X.                                                       ;
623% Alternatives for the structure of the such a child-scope_row are :        ;
624% -1- A combination of a non-empty Zstrt and a non-empty list Chrow   ;
625%     of children.                                                    ;
626% -2- An empty Zstrt, but a non-empty Chrow.                          ;
627% -3- A non-empty Zstrt, but an empty Chrow.                          ;
628% Special attention is required when in case -3- the Zstrt consists of;
629% only 1 Z-element besides the element shared with column Y.          ;
630% In case -2- similar care have to be taken when Chrow consists of 1  ;
631% scope_row index only.                                                     ;
632% Remark : Since the overall intention is optimization, i.e. reduction;
633% of the arithmetic complexity of a set of expressions, viewed as ru- ;
634% les to perform arithmetic operations, expression parts like a*b + a ;
635% are not changed into a*(b + 1). Hence a forth alternative, being an ;
636% empty Zstrt and an empty Chrow is irrelevant.                       ;
637% ------------------------------------------------------------------- ;
638begin scalar far,ch1,ch2,ch4,chindex,zel,zeli,zz2,zz3,zz4,
639                                         nsum,nprod,opv,y1,cof,x,ivalx;
640  far:=car(xx);
641  ch1:=scope_chrow(far);
642  zz3:=scope_zstrt(y);
643  nprod:=rowmax+1;
644  nsum:=rowmax:=rowmax+2;
645  % ----------------------------------------------------------------- ;
646  % After some initial settings all children,accessible via the Z-el.s;
647  % collected in Cdr(XX) are examined using a FOREACH_loop.           ;
648  % ----------------------------------------------------------------- ;
649  foreach item in cdr(xx) do
650  <<x:=xind item;
651    if (ivalx:=ival item)=1
652     then zz4:=delyzz(y,scope_zstrt x)
653     else zz4:=inszzzr(zeli:=mkzel(y,ivalx-1),delyzz(y,scope_zstrt x));
654    ch4:=scope_chrow(x);
655    cof:=scope_expcof(x);
656    % --------------------------------------------------------------- ;
657    % (Y.1) is removed from the child's Zstrt, defining a monomial,   ;
658    % without the coefficient, stored in Cof.                         ;
659    % --------------------------------------------------------------- ;
660    if null(zz4) and (null(cdr ch4) and car(ch4))
661    then
662    <<% ------------------------------------------------------------- ;
663      % This is the special case of possibility -2-. ZZ4 is empty and ;
664      % CH4 contains only 1 index.                                    ;
665      % ------------------------------------------------------------- ;
666      if (opv:=scope_opval(ch4:=car ch4)) eq 'plus and scope_expcof(ch4)=1
667      then
668      <<% ----------------------------------------------------------- ;
669        % The child with scope_row-index CH4 has the form (..+..+..)^1 = ..+;
670        %  ..+.. . Its definition has to be moved to the scope_row Nsum.    ;
671        % The different terms can be either primitive or composite and;
672        % have all to be multiplied by Cof. Both Zstrt(CH4) - the pri-;
673        % mitives - and Chrow(CH4) - the composites - have to be exa- ;
674        % mined.                                                      ;
675        % ----------------------------------------------------------- ;
676        foreach z in scope_zstrt(ch4) do
677        <<% --------------------------------------------------------- ;
678          % A new Zstrt ZZ2 is made with the primitive elements of the;
679          % the different Zstrt(CH4)'s. InsZZZr guarantees summation  ;
680          % of the Ival's if the Xind's are equal (see module CODMAT).;
681          % ZZ2 is build using the FOREACH X loop. The Zstrt's of the ;
682          % columns, which share an element with ZZ2,are also updated:;
683          % The CH4-indexed elements are removed and the Nsum-indexed ;
684          % elements are inserted.                                    ;
685          % --------------------------------------------------------- ;
686          zel:=mkzel(xind z,dm!-times(ival(z),cof));
687          zz2:=inszzzr(zel,zz2);
688          scope_setzstrt(yind z,inszzz(mkzel(nsum,ival zel),
689                                  delyzz(ch4,scope_zstrt yind z)))
690        >>;
691        foreach ch in scope_chrow(ch4) do
692        <<% --------------------------------------------------------- ;
693          % The scope_row CH defines a child directly if Cof = 1. In all    ;
694          % other cases a multiplication with Cof has to be performed.;
695          % Either by changing the ExpCof field if the child is a pro-;
696          % duct or by introducing a new TIMES-scope_row.                   ;
697          % --------------------------------------------------------- ;
698          chindex:=ch;
699          if not(!:onep cof)
700           then
701            if scope_opval(ch) eq 'times
702             then
703              << scope_setexpcof(ch,dm!-times(cof,scope_expcof(ch)));
704                 scope_setfarvar(ch,nsum)
705              >>
706             else
707              << chindex:=rowmax:=rowmax+1;
708                 setrow(chindex,'times,nsum,(ch).cof,nil)
709              >>
710           else  scope_setfarvar(ch,nsum);
711          ch2:=chindex.ch2
712        >>;
713        % ----------------------------------------------------------- ;
714        % The scope_row CH4 is not longer needed in CODMAT, because its     ;
715        % content is distributed over other rows.                     ;
716        % ----------------------------------------------------------- ;
717        clearrow(ch4);
718      >>
719      else
720      <<% ----------------------------------------------------------- ;
721        % This is still the special case -2-. (CH4) contains 1 child  ;
722        % index. The leading operator of this child is not PLUS. So   ;
723        % CH4 is simply added to the list of children indices CH2 and ;
724        % the father index of scope_row CH4 is changed into Nsum.           ;
725        % ----------------------------------------------------------- ;
726        scope_setfarvar(ch4,nsum);
727        ch2:=ch4.ch2
728      >>;
729      % ------------------------------------------------------------- ;
730      % The scope_row X is not longer needed in CODMAT, because its content ;
731      % is distributed over other rows.                               ;
732      % ------------------------------------------------------------- ;
733      clearrow(x)
734    >>
735    else
736     if null(ch4) and (null(cdr zz4) and car(zz4))
737      then
738      <<% ----------------------------------------------------------- ;
739        % This is the special case of possibility -3-: A Zstrt ZZ4    ;
740        % consisting of only one Z-element.                           ;
741        % This Z-element defines just a variable if IVal(Car ZZ4) =1. ;
742        % It is a power of a variable in case IVal-value > 1 holds.   ;
743        % In the latter situation Nsum ought to become the new father ;
744        % index of the scope_row with index Xind Car ZZ4.In the former case ;
745        % the single variable is added to the Zstrt ZZ2, before scope_row X ;
746        % can be cleared.                                             ;
747        % ----------------------------------------------------------- ;
748        if not(!:onep ival(car(zz4)))
749         then
750          << scope_setfarvar(x,nsum);
751             scope_setzstrt(x,zz4);
752             ch2:=x.ch2
753          >>
754         else
755          << zz2:=inszzzr(find!+var(scope_farvar(y1:=yind car zz4),nsum,
756                                                            cof),zz2);
757             scope_setzstrt(y1,delyzz(x,scope_zstrt y1));
758             clearrow(x)
759          >>
760      >>
761      else
762      <<% ----------------------------------------------------------- ;
763        % Now the general form of one of the 3 alternatives holds.    ;
764        % Row index X is added to the list of children indices CH2    ;
765        % and the new father index for scope_row X becomes Nsum. The Zstrt  ;
766        % of X is also reset. It becomes ZZ4, i.e. the previous Zstrt ;
767        % after removal of (Y.1).                                     ;
768        % ----------------------------------------------------------- ;
769        ch2:=x.ch2;
770        scope_setfarvar(x,nsum);
771        scope_setzstrt(x,zz4)
772      >>;
773    % --------------------------------------------------------------- ;
774    % The previous "life" of X is skipped by removing its impact from ;
775    % the "history book" CODMAT.                                      ;
776    % --------------------------------------------------------------- ;
777    ch1:=delete(x,ch1);
778    zz3:=delyzz(x,zz3);
779    if ivalx>2 then zz3:=inszzz(mkzel(x,val(zeli)),zz3)
780  >>;
781  % ----------------------------------------------------------------- ;
782  % Some final bookkeeping is needed :                                ;
783  % -1- (Y.1) was deleted from the ZZ4's. Its new role, factor in the ;
784  %     product,defined via the scope_row Nprod, has still to be establish- ;
785  %     ed by inserting this information in Y's Zstrt.                ;
786  % ----------------------------------------------------------------- ;
787   scope_setzstrt(y,(zel:=mkzel(nprod,1)).zz3);
788  % ----------------------------------------------------------------- ;
789  % -2- The list of indices of children of the scope_row with index Far     ;
790  %     ought to be extended with Nprod.                              ;
791  % ----------------------------------------------------------------- ;
792  scope_setchrow(far,nprod.ch1);
793  % ----------------------------------------------------------------- ;
794  % -3- Finally the new rows Nprod and Nsum have to be filled. How-   ;
795  %     ever the :=: assignment-option might cause - otherwise non-   ;
796  %     existing - problems, because simplification is skipped before ;
797  %     parsing input and storing the relevant information in CODMAT. ;
798  % An input expression of the form x*(a + t) + x*(a - t) can thus be ;
799  % transformed - by an application of CODFAC - into the form         ;
800  % x*(2*a + 0). Its Zstrt can contain an element (index  . 0), like  ;
801  % the Zstrt associated with t. The latter is due to the coefficient ;
802  % addition, implied by insert-operations, like InsZZZ or InsZZZr.   ;
803  % Hence a test is made to discover if a Z-element Zel exists, such  ;
804  % that IVal(Zel)=0. If so, its occurrence is removed from both ZZ2  ;
805  % and the Zstrt of the t-column.                                    ;
806  % If now Null(CH2) and Null(Cdr ZZ2) holds the PLUS-scope_row Nsum is     ;
807  % superfluous. Only 2*a*x has to be stored in Nprod. The scope_row Nsum   ;
808  % is removed when it is easily detectable, because this index is    ;
809  % not used anymore and anywhere, when the above limitations are     ;
810  % valid.                                                            ;
811  % ----------------------------------------------------------------- ;
812  foreach z in zz2 do if zeropp(ival(z))
813     then << zz2:=delyzz(y1:=xind z,zz2);
814             scope_setzstrt(y1,delyzz(nsum,scope_zstrt y1))
815          >>;
816  % ----------------------------------------------------------------- ;
817  % Expressions like x(a-w)+x(a+w) lead to printable, but not yet to  ;
818  % completely satisfactory prefixlist-representations. This problem  ;
819  % is solved in the module CODPRI in the function  ConstrExp.        ;
820  % ----------------------------------------------------------------- ;
821  setrow(nprod,'times,far,list list nsum,list mkzel(y,val zel));
822  setrow(nsum,'plus,nprod,list ch2,zz2)
823 end;
824
825endmodule;
826
827end;
828