Artifact 40272c890de9be519928dcda7ac17008b2a09a00784d0a29bb823f5cbe92811f:
- Executable file
r37/packages/scope/codstr.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 11389) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/scope/codstr.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 11389) [annotate] [blame] [check-ins using]
module gstructr; % Generalized structure routines. % ------------------------------------------------------------------- ; % Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ; % Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.; % Author : M.C. van Heerwaarden, J.A. van Hulzen ; % ------------------------------------------------------------------- ; symbolic$ % ------------------------------------------------------------------- ; % This module contains an extended version of the structr facility of ; % REDUCE. ; % ; % Author of structr-routines: Anthony C. Hearn. ; % ; % Copyright (c) 1987 The RAND Corporation. All rights reserved. ; % ; % ------------------------------------------------------------------- ; % ------------------------------------------------------------------- ; % This is a generalization of the STRUCTR-command. Instead of one ; % expression, GSTRUCTR takes as input a list of assignment statements.; % SYNTAX: ; % <gstructr-command> ::= GSTRUCTR <ass-list> NAME <id> ; % <ass-list> ::= {<assignments> | <matrix>} ; % <id> ::= <name for CSE> ; % As a result, all assignments are printed with substitutions for the ; % CSE's. Then WHERE is printed, followed by the list of CSE's. These ; % CSE's are printed in reversed order. Matrices are treated as if ; % assignments were made for all matrix elements. ; % When the switch FORT is ON, the statements will be in FORTRAN execu; % table order. Be sure PERIOD is OFF when using a matrix,since FORTRAN; % expects integer subscripts, and REDUCE generates a floating point ; % representation for these subscripts when PERIOD is ON. ; % The switch ALGPRI can be turned OFF when the list of assignments is ; % needed in prefix-form. ; % ------------------------------------------------------------------- ; fluid '(countr svar !*varlis); global '(!*algpri ); %global '(!*fort ); %global '(!*nat ); %global '(!*savestructr); global'(varnam!*); switch savestructr, algpri; % loadtime(on algpri); % ***** two essential uses of RPLACD occur in this module. put('gstructr, 'stat, 'gstructrstat); symbolic procedure gstructrstat; begin scalar x,y; flag('(name), 'delim); if eqcar(x := xread t, 'progn) then x := cdr x else x := list x; if cursym!* = 'name then y := xread t; remflag('(name), 'delim); return list('gstructr, x, y) end; put('gstructr, 'formfn, 'formgstructr); symbolic procedure formgstructr(u, vars, mode); list('gstructr, mkquote cadr u, mkquote caddr u); symbolic procedure gstructr(assset, name); begin !*varlis := nil; countr := 0; for each ass in assset do if not pairp ass then if get(ass, 'rtype) = 'matrix then prepstructr(cadr get(ass,'avalue),name,ass) else rederr {ass, "is not a matrix"} else prepstructr(caddr ass, name, cadr ass); if !*algpri then print!*varlis() else return remredundancy(for each x in reversip!* !*varlis collect list('setq, cadr x, cddr x)) end; symbolic procedure prepstructr(u, name, fvar); begin scalar i, j; %!*VARLIS is a list of elements of form: %(<unreplaced expression> . <newvar> . <replaced exp>); if name then svar := name else svar := varnam!*; u := aeval u; if flagpcar(u, 'struct) then << i := 0; u:= car u . (for each row in cdr u collect << i := i + 1; j := 0; for each column in row collect << j := j + 1; !*varlis := (nil . list(fvar,i,j) . prepsq prepstruct!*sq column) . !*varlis >> >> ) >> else if getrtype u then typerr(u,"STRUCTR argument") else !*varlis:=(nil.fvar.prepsq prepstruct!*sq u).!*varlis end; symbolic procedure print!*varlis; begin if !*fort then !*varlis := reversip!* !*varlis; if not !*fort then << for each x in reverse !*varlis do if null car x then << assgnpri(cddr x,list cadr x,t); if not flagpcar(cddr x,'struct) then terpri(); if null !*nat then terpri() >>; if countr=0 then return nil; prin2t " where" >>; for each x in !*varlis do if !*fort or car x then <<terpri!* t; if null !*fort then prin2!* " "; assgnpri(cddr x,list cadr x,t) >>; if !*savestructr then <<if arrayp svar then <<put(svar,'array, % mkarray(list(countr+1),'algebraic)); mkarray1(list(countr+1),'algebraic)); put(svar,'dimension,list(countr+1))>>; for each x in !*varlis do if car x then setk2(cadr x,mk!*sq !*k2q car x)>> end; symbolic procedure prepstruct!*sq u; if eqcar(u,'!*sq) then prepstructf numr cadr u ./ prepstructf denr cadr u else u; symbolic procedure prepstructf u; if null u then nil else if domainp u then u else begin scalar x,y; x := mvar u; if sfp x then if y := assoc(x,!*varlis) then x:=cadr y else x:=prepstructk(prepsq!*(prepstructf x ./ 1), prepstructvar(),x) else if not atom x and not atomlis cdr x then if y := assoc(x,!*varlis) then x := cadr y else x := prepstructk(x,prepstructvar(),x); return x .** ldeg u .* prepstructf lc u .+ prepstructf red u end; symbolic procedure prepstructk(u,id,v); begin scalar x; if x := prepsubchk1(u,!*varlis,id) then rplacd(x,(v . id . u) . cdr x) else if x := prepsubchk2(u,!*varlis) then !*varlis := (v . id . x) . !*varlis else !*varlis := (v . id . u) . !*varlis; return id end; symbolic procedure prepsubchk1(u,v,id); begin scalar w; while v do <<smember(u,cddar v) and <<w := v; rplacd(cdar v,subst(id,u,cddar v))>>; v := cdr v>>; return w end; symbolic procedure prepsubchk2(u,v); begin scalar bool; for each x in v do smember(cddr x,u) and <<bool := t; u := subst(cadr x,cddr x,u)>>; if bool then return u else return nil end; symbolic procedure prepstructvar; begin countr := countr + 1; return if arrayp svar then list(svar,countr) else compress append(explode svar,explode countr) end; symbolic procedure remredundancy setqlist; % -------------------------------------------------------------------- ; % This function is used for backsubstitution of values of identifiers ; % in rhs's if the corresponding identifier occurs only once in the set ; % of rhs's. SetqList is thus made shorter if possible. ; % An element of Setqlist has the form (SETQ assname value), where ; % assname can be redundant if ; % Atom(assname) and Letterpart(assname) = svar ; % -------------------------------------------------------------------- ; begin scalar lsl,lhs,rhs,relevant,j,var,freq,k,firstocc,templist; lsl:=length(setqlist); lhs:=mkvect(lsl); rhs:=mkvect(lsl); relevant:=mkvect(lsl); j:=0; var:=explode(svar); foreach item in setqlist do <<putv(lhs,j:=j+1,cadr item); putv(rhs,j,caddr item); if atom(cadr item ) and letterparts(cadr item) = var then putv(relevant,j,t) >>; for j:=1:lsl do if getv(relevant,j) then << var:=getv(lhs,j); freq:=0; k:=j; firstocc:=0; while freq=0 and k<lsl do << if (freq:=numberofoccs(var,getv(rhs,k:=k+1)))=1 and firstocc=0 then <<firstocc:=k; freq:=0>>; if firstocc>0 and freq>0 then firstocc:=0 >>; if firstocc=0 then templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist else putv(rhs,firstocc, subst(getv(rhs,j),var,getv(rhs,firstocc))) >> else templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist; return reverse(templist); end; symbolic procedure letterparts(name); % ----------------------------------------------------------------- ; % Eff: The exploded form of the Letterpart of Name returned, i.e. ; % (!a !a) if Name=aa55. ; % ----------------------------------------------------------------- ; begin scalar letters; letters:=reversip explode name; while digit car letters do letters:=cdr letters; return reversip letters end; symbolic procedure numberofoccs(var,expression); % -------------------------------------------------------------------- ; % The number of occurrences of Var in Expression is computed and ; % returned. ; % -------------------------------------------------------------------- ; if atom(expression) then if var=expression then 1 else 0 else (if cdr expression then numberofoccs(var,cdr expression) else 0) + (if var=car expression then 1 else if not atom car expression then numberofoccs(var,car expression) else 0); %----------------------------------------------------------------------- % Algebraic mode psop-function definition. %----------------------------------------------------------------------- symbolic procedure algstructreval u; % -------------------------------------------------------------------- ; % Variant of gstructr-command. Accepts list of equations and optionally % an initial part of a subpart recognizer name. % -------------------------------------------------------------------- ; begin scalar algpri,name,period,res; integer nargs; nargs:=length u; name:= (if nargs=1 and getd('newsym) then fnewsym() else if nargs=2 then cadr u else '!*!*error!*!*); if eq(name,'!*!*error!*!*) then rederr("WRONG NUMBER OF ARGUMENTS ALGSTRUCTR") else << algpri:=!*algpri; period:=!*period; !*algpri:=!*period:=nil; res:=apply('gstructr,list(cdar u,name)); !*period:=period; if (!*algpri:=algpri) then return algresults1(foreach el in res collect cons(cadr el,caddr el)) else return res >> end; put('algstructr,'psopfn,'algstructreval)$ endmodule; end;