Artifact 676233b4e8d61f855e9e10e76800b4e2591bacbc72a0421a2488712f4afc6bee:
- Executable file
r37/packages/alg/map.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: 3606) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/alg/map.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: 3606) [annotate] [blame] [check-ins using]
module map; % Mapping univariate functions to composite objects. % Author: Herbert Melenk. % Syntax: map(unary-function,linear-structure-or-matrix) % % map(sqrt ,{1,2,3,4}); % map(df(~u,x),mat((x^2,sin x))); % % select(unary-predicate,linear-structure) % % select(evenp,{1,2,3,4,5,6,7}); % select(evenp deg(~u,x),(x+y)^5); % % The function/predicate may contain one free variable. put('!~map,'oldnam,'map); put('map,'newnam,'!~map); put('!~map,'psopfn,'map!-eval); put('!~map,'rtypefn,'getrtypecadr); symbolic procedure getrtypecadr u; getrtype cadr u; symbolic procedure map!-eval u; <<if length u neq 2 then rederr "illegal number of arguments for map"; map!-eval1(reval cadr u,car u, function(lambda y;y),'aeval)>>; symbolic procedure !~map(b,a); % Called only inside matrix expressions. cdr map!-eval1('mat . matsm a,b, function (lambda w; list('!*sq,w,t)),'simp); symbolic procedure map!-eval1(o,q,fcn1,fcn2); % o structure to be mapped. % q map expression (univariate function). % fcn1 function for evaluating members of o. % fcn2 function computing results (e.g. aeval). begin scalar v,w; v := '!&!&x; if idp q and (get(q,'simpfn) or get(q,'number!-of!-args)=1) then <<w:=v; q:={q,v}>> else if eqcar(q,'replaceby) then <<w:=cadr q; q:=caddr q>> else <<w:=map!-frvarsof(q,nil); if null w then rederr "map/select: no free variable found" else if cdr w then rederr "map/select: free variable ambiguous"; w := car w; >>; if eqcar(w,'!~) then w:=cadr w; q := sublis({w.v,{'!~,w}.v},q); if atom o then rederr "cannot map for atom"; return if car o ='mat then 'mat . for each row in cdr o collect for each w in row collect map!-eval2(w,v,q,fcn1,fcn2) else car o . for each w in cdr o collect map!-eval2(w,v,q,fcn1,fcn2); end; symbolic procedure map!-eval2(w,v,q,fcn1,fcn2); begin scalar r; r :=evalletsub2({{{'replaceby ,v,apply1(fcn1,w)}}, {fcn2,mkquote q}},nil); if errorp r then rederr "error during map"; return car r; end; symbolic procedure map!-frvarsof(q,l); if atom q then l else if car q eq '!~ then if q member l then l else q.l else map!-frvarsof(cdr q,map!-frvarsof(car q,l)); symbolic procedure select!-eval u; % select from a list l members according to a boolean test. begin scalar l,w,v,r; l := reval cadr u; w := car u; if atom l or (car l neq'list and not flagp(car l,'nary)) then typerr(l,"select operand"); if idp w and get(w,'number!-of!-args)=1 then w:={w,{'~,'!&!&}}; if eqcar(w,'replaceby) then <<v:=cadr w;w:=caddr w>>; w:=freequote formbool(w,nil,'algebraic); if v then w:={'replaceby,v,w}; r:=for each q in pair(cdr map!-eval1(l,w,function(lambda y;y),'lispeval),cdr l) join if car q and car q neq 0 then {cdr q}; if r then return car l . r; if (r:=atsoc(car l,'((plus . 0)(times . 1)(and . 1)(or . 0)))) then return cdr r else rederr {"empty selection for operator ",car l} end; symbolic procedure freequote u; % Preserve structure where possible. if atom u then u else if car u eq 'list and cdr u and cadr u = '(quote !~) then mkquote{'!~,cadr caddr u} else (if v=u then u else v) where v = freequote car u . freequote cdr u; put('select,'psopfn,'select!-eval); put('select,'number!-of!-args,2); endmodule; end;