Artifact d3fd46be79925b0d357557469f3220a2629622b2830cf29970574be0108fd656:
- Executable file
r36/src/rlfi.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: 21524) [annotate] [blame] [check-ins using] [more...]
module rlfi; %*********************************************************************** %***** ****** %***** M O D U L E R L F I Ver. 1.2.1 23/05/1995 ****** %***** ****** %*********************************************************************** %***** Program for LATEX syntax of REDUCE output formulas, ****** %***** to activate it, turn the LATEX switch ON. ****** %***** Program can be used only on systems supporting lower ****** %***** case characters through OFF RAISE. ****** %***** Note that in REDUCE 3.6 one has to input REDUCE commands ****** %***** in lower case!!!!! ****** %*********************************************************************** % Author: Richard Liska % Faculty of Nuclear Sciences and Physical Engineering % Czech Technical University in Prague % Brehova 7, 115 19 Prague 1, Czech Republic % E-mail: liska@siduri.fjfi.cvut.cz % Program RLFI, Version REDUCE 3.6 23/05/1995 % History: % Ver. 1.01 17/11/1989 ****** % Ver. 1.1 27/05/1991 ****** % Ver. 1.1.1 27/08/1992 ****** added lists % Ver. 1.2 02/10/1992 ****** corrected lists, underscores _, % added all prefix operators from REDUCE kernel and SOLVE, % subscripts for ARBINT etc., VERBATIM OFF by default - % prints REDUCE Input: (to avoid empty verbatims), corrected % repeated printing of longer ids, added ROUNDED numbers % Ver. 1.2.1 23/05/1995 ****** minor change to 3.6 create!-package('(rlfi),'(contrib misc)); fluid'(posn!* orig!*); % Global variables and their default values global '(mstyle!* nochar!* nochar1!* linel!* laline!* ncharspr!* mstyles!*); nochar!*:=nil; % List of identifiers longer than one character % used in previous commands nochar1!*:=nil; % List of identifiers longer than one character % in actual command which are used for the first time laline!*:=72; % Linelength of output file ncharspr!*:=0; % Position on output line linel!*:=linelength nil . laline!*; % actual length of line mstyle!*:='!d!i!s!p!l!a!y!m!a!t!h; % Default mathematical style % Possible math. styles mstyles!*:= '(!m!a!t!h !d!i!s!p!l!a!y!m!a!t!h !e!q!u!a!t!i!o!n); % Declaration of symbols and operators for LaTeX flag('(!a!lp!h!a !b!e!t!a !g!a!m!m!a !d!e!l!t!a !e!p!s!i!l!o!n !v!a!r!e!p!s!i!l!o!n !z!e!t!a !e!t!a !t!h!e!t!a !v!a!r!t!h!e!t!a !i!o!t!a !k!a!p!p!a !l!a!m!b!d!a !m!u !n!u !x!i !p!i !v!a!r!p!i !r!h!o !v!a!r!r!h!o !s!i!g!m!a !v!a!r!s!i!g!m!a !t!a!u !u!p!s!i!l!o!n !p!h!i !v!a!r!p!h!i !c!h!i !p!s!i !o!m!e!g!a !G!a!m!m!a !D!e!l!t!a !T!h!e!t!a !L!a!m!b!d!a !X!i !P!i !S!i!g!m!a !U!p!s!i!l!o!n !P!h!i !P!s!i !O!m!e!g!a !i!n!f!t!y !h!b!a!r !n!a!b!l!a !p!e!r!p alpha beta gamma delta epsilon varepsilon zeta eta theta vartheta iota kappa lambda mu nu xi pi varpi rho varrho sigma varsigma tau upsilon phi varphi chi psi omega gamma delta theta lambda xi pi sigma upsilon phi psi omega infty hbar nabla perp),'symbol); flag('(!h!a!t !c!h!e!c!k !b!r!e!v!e !a!c!u!t!e !g!r!a!v!e !t!i!l!d!e !b!a!r !v!e!c !d!o!t !d!d!o!t hat check breve acute grave tilde bar vec dot ddot),'accdef); deflist('((!b!o!l!d !{!\!b!f! )(!r!o!m!a!n !{!\r!m! ) (bold !{!\!b!f! )(roman !{!\r!m! )),'fontdef); deflist('((!( !\!l!e!f!t!() (!) !\!r!i!g!h!t!)) (!P!I !\!p!i! ) (!p!i !\pi! ) (!E !e) (!I !i) (e !e) (i !i)),'name); deflist('((times ! )(setq !=)(geq !\!g!e!q! )(leq !\!l!e!q! )),'lapr); % LaTeX supported operators deflist('( (acos !\!a!r!c!c!o!s) (coth !\!c!o!t!h) (sec !\!s!e!c) (asin !\!a!r!c!s!i!n) (csc !\!c!s!c) (sin !\!s!i!n) (atan !\!a!r!c!t!a!n) (exp !\!e!x!p) (sinh !\!s!i!n!h) (arg !\!a!r!g) (ln !\!l!n) (tan !\!t!a!n) (cos !\!c!o!s) (log !\!l!o!g) (tanh !\!t!a!n!h) (cosh !\!c!o!s!h) (max !\!m!a!x) (sum !\!s!u!m) (cot !\!c!o!t) (min !\!m!i!n) (product !\!p!r!o!d) ),'lapop); % Other REDUCE operators deflist('( (abs "{\rm abs}") (deg2rad "{\rm deg2rad}") (acosd "{\rm acosd}") (dilog "{\rm dilog}") (acosh "{\rm acosh}") (dms2deg "{\rm dms2deg}") (acot "{\rm acot}") (dms2rad "{\rm dms2rad}") (acotd "{\rm acotd}") (erf "{\rm erf}") (acoth "{\rm acoth}") (expint "{\rm expint}") (acsc "{\rm acsc}") (factorial "{\rm factorial}") (acscd "{\rm acscd}") (fix "{\rm fix}") (acsch "{\rm acsch}") (floor "{\rm floor}") (arbcomplex "{\rm arbcomplex}") (hypot "{\rm hypot}") (arbint "{\rm arbint}") (icbrt "{\rm icbrt}") (arbreal "{\rm arbreal}") (ilog2 "{\rm ilog2}") (argd "{\rm argd}") (impart "{\rm impart}") (asec "{\rm asec}") (irootn "{\rm irootn}") (asecd "{\rm asecd}") (isqrt "{\rm isqrt}") (asech "{\rm asech}") (log10 "{\rm log10}") (asind "{\rm asind}") (logb "{\rm logb}") (asinh "{\rm asinh}") (norm "{\rm norm}") (atan2 "{\rm atan2}") (one_of "{\rm one_of}") (atan2d "{\rm atan2d}") (perm "{\rm perm}") (atand "{\rm atand}") (rad2deg "{\rm rad2deg}") (atanh "{\rm atanh}") (rad2dms "{\rm rad2dms}") (cbrt "{\rm cbrt}") (repart "{\rm repart}") (ceiling "{\rm ceiling}") (root_of "{\rm root_of}") (choose "{\rm choose}") (round "{\rm round}") (cosd "{\rm cosd}") (secd "{\rm secd}") (cosh "{\rm cosh}") (sech "{\rm sech}") (cotd "{\rm cotd}") (sgn "{\rm sgn}") (cscd "{\rm cscd}") (sind "{\rm sind}") (csch "{\rm csch}") (sol "{\rm sol}") (deg2dms "{\rm deg2dms}") (tand "{\rm tand}") ),'lapop); symbolic procedure get!*(u,v); if numberp u then nil else get(u,v); fluid '(!*latex !*lasimp !*verbatim !*!*a2sfn); switch latex,lasimp,verbatim; !*lasimp := t; symbolic put('latex,'simpfg,'((t (latexon)) (nil(latexoff)) )); symbolic put('verbatim,'simpfg,'((t (verbatimon)) (nil (verbatimoff)))); symbolic procedure latexon; % Procedure called after ON LATEX <<!*!*a2sfn:='texaeval; !*raise:=nil; prin2t "\documentstyle{article}"; prin2t "\begin{document}"; if !*verbatim then <<prin2t "\begin{verbatim}"; prin2t "REDUCE Input:">>; put('tex,'rtypefn,'(lambda(x) 'tex)) >>; symbolic procedure latexoff; % Procedure called after OFF LATEX <<!*!*a2sfn:='aeval; !*raise:=t; remprop('tex,'rtypefn); if !*verbatim then <<terpri(); prin2t "\end{verbatim}" >>; prin2t "\end{document}"; rmsubs() >>; procedure verbatimon; <<if !*latex and null !*verbatim then <<prin2t "\begin{verbatim}"; prin2t "REDUCE Input:">>; !*echo:=t>>; procedure verbatimoff; <<if !*latex and !*verbatim then <<terpri(); prin2t "\end{verbatim}">>; !*echo:=nil >>; symbolic procedure texaeval u; % Procedure replaces the AEVAL procedure in the LATEX mode if !*lasimp then list('tex,aeval u) else list('tex,u); % deklarace latex modu; put('tex,'tag,'tex); put('tex,'simpfn,'simp); put('tex,'typeletfn,'texlet); put('tex,'prifn,'latexprint); put('tex,'setprifn,'setlaprin); flag('(tex),'sprifn); symbolic procedure texlet(u,v,tu,b,tv); % Assignment procedure for LATEX mode % !!! match can be evaluated like let!!!!; if eqcar(v,'tex) then let2(u,cadr v,nil,b) else msgpri(" value for ",u," not assigned ",v,nil); symbolic procedure latexprint u; % Prints expression U in the LaTeX syntax <<prinlabegin(); latexprin u; prinlaend() >>; symbolic procedure setlaprin(u,v); % Prints assignment command in LaTeX syntax <<prinlabegin(); latexprin u; oprinla 'setq; latexprin v; prinlaend() >>; symbolic procedure mathstyle u; % Defines the output mathematical style if car u memq mstyles!* then <<mstyle!*:=car u;nil>> else msgpri(" mathematical style ",car u," not supported ",nil,nil); put('mathstyle,'stat,'rlis); symbolic procedure prinlabegin; % Initializes the output <<if !*verbatim then <<terpri(); prin2t "\end{verbatim}">>; linel!*:=linelength nil . laline!*; if ofl!* then linelength(laline!* + 2) else laline!*:=car linel!* - 2; prin2 "\begin{"; prin2 mstyle!*; prin2t "}" >>; symbolic procedure prinlaend; % Ends the output of one expression <<terpri(); prin2 "\end{"; prin2 mstyle!*; prin2t "}"; if !*verbatim then <<prin2t "\begin{verbatim}"; prin2t "REDUCE Input:">>; ncharspr!*:=0; if nochar1!* then msgpri(" Longer than one character identifiers used ", nil,nochar1!*,nil,nil); if ofl!* then linelength(car linel!*) else laline!*:=cdr linel!*; nochar!*:=append(nochar!*,nochar1!*); nochar1!*:=nil >>; symbolic procedure latexprin u; % Prints expression U in the LaTeX syntax if eqcar(u,'tex) then maprintla(cadr u,0) else maprintla(u,0); symbolic procedure texprla(u,p); maprintla(car u,p); put('tex,'laprifn,'texprla); symbolic procedure maprintla(l,p); % L is printed expression, P is the infix precedence of infix operator % Procedure is similar to that one in the REDUCE source begin scalar x; if null l then return nil else if numberp l then go to c else if atom l then return prinlatom l else if stringp l then return prin2la l else if not atom car l then return maprintla(car l,p) else if (x:=get(car l,'laprifn)) and ((not flagp(car l,'fulla) and not (apply(x,list(cdr l,p)) eq 'failed)) or (flagp(car l,'fulla) and not(apply(x,list(l,p)) eq 'failed))) then return l else if (x:=get(car l,'indexed)) then return prinidop(car l,cdr l,x) else if x:=get(car l,'infix) then go to a else if car l eq '!:rd!: then return begin scalar !*nat,ll; % max. estimate ll:=if floatp cdr l then lengthc cdr l else lengthc cadr l + lengthc cddr l + 5; if ncharspr!* + ll > laline!* then <<terpri(); ncharspr!*:=ll >> else ncharspr!*:=ncharspr!* + ll; posn!*:=orig!*; rd!:prin l end; oprinla(car l); prinpopargs(car l,cdr l,p); return l; a:p:=x>p; if null p and car l eq 'equal then p:=t; if p then go to b; prinlatom '!(; b:inprinla(car l,x,cdr l); if p then return l; prinlatom '!); return l; c:if not(l<0) or p<get('minus,'infix) then return prin2la l; prin2la '!(; prin2la l; prin2la '!); return l end; symbolic procedure prinpopargs(op,args,p); % Prints argument(s) of prefix operator, decides if arg(s) will be % enclosed in parantheses begin scalar x; x:=null args or cdr args or not atom car args; % x:=x or null get(op,'lapop); if x then prinlatom '!( else prin2la "\,"; if args then inprinla('!*comma!*,0,args); if x then prinlatom '!); if null x and p=get('times,'infix) then prin2la "\:"; return args end; symbolic procedure prinlatom u; % Prints atom or the symbol associated to the atom in given font % and with given accent begin scalar n,f,a; if f:=get(u,'font) then prin2la f; if a:=get(u,'accent) then prin2la a; if n:=get(u,'name) then prin2la n else prin2la testchar1 u; if a then prin2la "}"; if f then prin2la "}"; return u end; symbolic procedure defid u; % Defines the statement DEFID for defining symbol, font and accent % associated to given atom begin scalar at,x,y; at:=car u; if not atom at or null car u then go to er; a:u:=cdr u; x:=car u; if eqcar(x,'equal) then x:=cdr x else go to er; if car x eq 'name then if flagp(cadr x,'symbol) then put(at,'name,incompe3('!\,cadr x,'! )) else put(at,'name,testchar1 cadr x) else if car x eq 'font then if y:=get(cadr x,'fontdef) then put(at,'font,y) else go to er else if car x eq 'accent then if flagp(cadr x,'accdef) then put(at,'accent,incompe3('!\,cadr x,'!{)) else go to er else go to er; if cdr u then go to a; return nil; er:lprie(" Syntax error ") end; put('defid,'stat,'rlis); symbolic procedure incompe3(a,b,c); % Constructs new atom by concatenating A,B,C intern compress append(explode a,append(explode b,explode c)); symbolic procedure testchar1 u; % Checks if id U has only one character if fixp u then u else if null cdr explode2 u then u else if member(u,nochar!*) then u else if member(u,nochar1!*) then u else <<nochar1!*:=u . nochar1!*; u>>; procedure chundexp u; % Replaces underscores _ in ids by \_ % except if u = !_ begin scalar x; u:=explode2 u; x:=u; if eqcar(u,'_) and cdr u then u:='!\ . u; a:if null cdr x then goto r; if cadr x eq '_ then <<rplacd(x,'!\ . cdr x); x:=cdr x>>; x:=cdr x; goto a; r:return u end; symbolic procedure inprinla(op,p,l); % Prints infix operator OP with arguments in the list L begin if get(op,'alt) then go to a; maprintla(car l,p); a0:l:=cdr l; a:if null l then return nil else if atom car l or not(op eq get!*(caar l,'alt)) then <<oprinla op; maprintla(negnumberchk car l,p)>> else maprintla(car l,p); go to a0; end; symbolic procedure oprinla op; % Prints operator OP begin scalar x; if x:=get(op,'lapr) then prin2la x else if x:=get(op,'prtch) then prin2la x else if x:=get(op,'lapop) then <<prin2la x; prin2la '! >> else prinlatom op end; % Definition of new operator of division --> horizontal division line newtok '((!\) backslash); deflist('((backslash recip)),'unary); algebraic infix \; precedence 'backslash,'quotient; put('backslash,'simpfn,'simpiden); symbolic procedure prin2la u; % Prints atom or string U, checks the length of line % CHUNDEXP makes the change _ -> \_ begin scalar l; u:=chundexp u; l:=length u; if ncharspr!* + l > laline!* then <<terpri(); ncharspr!*:=0 >>; for each a in u do prin2 a; ncharspr!*:=ncharspr!* + l end; symbolic procedure prinfrac(l,p); % Prints the fraction with horizontal division line <<prin2la "\frac{"; maprintla(car l,0); prin2la "}{"; maprintla(cadr l,0); prin2la "}" >>; put('backslash,'laprifn,'prinfrac); symbolic procedure defindex u; % Defines the placing of indices of an operator for each a in u do defindex1 a; put('defindex,'stat,'rlis); symbolic procedure defindex1 u; begin scalar at,x; at:=car u; for each a in cdr u do if not(a memq '(arg up down leftup leftdown)) then x:=t; if not atom at or null cdr u then x:=t; return if x then msgpri(" Syntax error ",u,nil,nil,'hold) else put(at,'indexed,cdr u) end; symbolic procedure prinidop(op,args,mask); % Prints operator with indices. MASK describe the place of indices begin scalar arg,up,down,lup,ldown; if null args then return prinlatom op; a:if car mask eq 'arg then arg:=car args . arg else if car mask eq 'up then up:=car args . up else if car mask eq 'down then down:=car args . down else if car mask eq 'leftup then lup:=car args . lup else if car mask eq 'leftdown then ldown:=car args . ldown; mask:=cdr mask; args:=cdr args; if mask and args then go to a; mask:='(arg); if args then go to a; arg:=reverse arg; up:=reverse up; down:=reverse down; lup:=reverse lup; ldown:=reverse ldown; if lup or ldown then prin2la "\:"; if lup then <<prin2la '!^!{; prinindexs lup; prin2la "}" >>; if ldown then <<prin2la "_"; prin2la "{"; prinindexs ldown; prin2la "}" >>; oprinla op; if up then <<prin2la '!^!{; prinindexs up; prin2la "}" >>; if down then <<prin2la "_"; prin2la "{"; prinindexs down; prin2la "}" >>; if arg then <<prinlatom '!(; inprinla('!*comma!*,0,arg); prinlatom '!) >>; return op end; symbolic procedure prinindexs ndxs; % Prints indexces NDXS, if all indices are atoms prints them withouth % separating commas begin scalar b; for each a in ndxs do if not atom a then b:=t; if not b then for each a in ndxs do prinlatom a else inprinla('!*comma!*,0,ndxs) end; symbolic procedure exptprla(args,p); % Prints powers begin scalar arg,exp,ilist; arg:=car args; exp:=cadr args; if not atom exp and car exp eq 'quotient and cadr exp = 1 and atom caddr exp then if caddr exp = 2 then <<prin2la "\sqrt{"; maprintla(arg,0); prin2la "}" >> else <<prin2la "\sqrt["; prinlatom caddr exp; prin2la "]{"; maprintla(arg,0); prin2la "}" >> else if atom arg then <<prinlatom arg; prin2la '!^!{; maprintla(exp,0); prin2la "}" >> else if atom car arg and not (ilist:=get(car arg,'indexed)) and not get(car arg,'laprifn) and not get(car arg,'infix) and atom exp then <<oprinla car arg; prin2la '!^!{; prinlatom exp; prin2la "}"; prinpopargs(car arg,cdr arg,p) >> else if atom car arg and (ilist:=get(car arg,'indexed)) and not memq('up,ilist) then <<maprintla(arg,0); prin2la '!^!{; maprintla(exp,0); prin2la '!} >> else <<prinlatom '!(; maprintla(arg,0); prinlatom '!); prin2la '!^!{; maprintla(exp,0); prin2la "}" >>; return args end; put('expt,'laprifn,'exptprla); procedure sqrtprla(arg,p); % Prints square root <<prin2la "\sqrt {"; maprintla(car arg,0); prin2la "}" >>; put('sqrt,'laprifn,'sqrtprla); symbolic procedure intprla(args,p); % Prints indefinite itegral begin scalar arg,var; if null args or null cdr args or not atom cadr args then return 'failed; arg:=car args; var:=cadr args; prin2la "\int "; maprintla(arg,0); prin2la "\:d\,"; prinlatom var; return args end; put('int,'laprifn,'intprla); symbolic procedure dintprla(args,p); % Prints definite integral begin scalar down,up,arg,var; if null args or null cdr args or null cddr args or null cdddr args or not atom (var:=cadddr args) then return 'failed; down:=car args; up:=cadr args; arg:=caddr args; prin2la "\int"; prin2la "_"; prin2la "{"; maprintla(down,0); prin2la "}^{"; maprintla(up,0); prin2la "}"; maprintla(arg,0); prin2la "\:d\,"; prinlatom var; return args end; put('dint,'laprifn,'dintprla); symbolic procedure sumprla(ex,p); % Prints a sum begin scalar op,down,up,arg; if not get(op:=car ex,'lapop) or null cdr ex or null cddr ex or null cdddr ex then return 'failed; down:=cadr ex; up:=caddr ex; arg:=cadddr ex; oprinla op; if down then <<prin2la "_"; prin2la "{"; maprintla(down,0); prin2la "}" >>; if up then <<prin2la '!^!{; maprintla(up,0); prin2la "}" >>; maprintla(arg,get('times,'infix) - 1); return ex end; put('sum,'laprifn,'sumprla); put('product,'laprifn,'sumprla); flag('(sum product),'fulla); symbolic procedure sqprla(args,p); % Prints standard quotient maprintla(prepsq!* car args,p); put('!*sq,'laprifn,'sqprla); symbolic procedure dfprla(dfex,p); % Prints derivaves begin scalar op,ord,arg,x,argup; op:=get(car dfex,'lapop); arg:=cadr dfex; dfex:=cddr dfex; x:=dfex; ord:=0; a:if null cdr x then <<x:=cdr x; ord:=ord+1 >> else if fixp cadr x then <<ord:=ord+cadr x; x:=cddr x >> else <<x:=cdr x; ord:=ord+1 >>; if x then go to a; if atom arg or (not get(car arg,'infix) and not get(car arg,'laprifn)) then argup:=t; prin2la "\frac{"; prin2la op; if ord=1 then prin2la "\," else <<prin2la '!^!{; prin2la ord; prin2la "}" >>; if argup then maprintla(arg,0); prin2la "}{"; x:=dfex; b:if not atom car x and cdr x and fixp cadr x then prin2la "("; prin2la op; if null cdr x or not fixp cadr x then <<prin2la "\,"; maprintla(car x,0); x:=cdr x >> else <<maprintla(car x,0); if not atom car x then prin2la ")"; prin2la '!^!{; prin2la cadr x; prin2la "}"; x:=cddr x >>; if x then go to b; prin2la "}"; if null argup then maprintla(arg,get('quotient,'infix)); return arg end; put('df,'laprifn,'dfprla); put('pdf,'laprifn,'dfprla); flag('(df pdf),'fulla); put('df,'lapop,"{\rm d}"); put('pdf,'lapop,"\partial "); procedure listprla(args,p); % Prints list of expressions if args then <<prin2t "\left\{"; maprintla(car args,0); args:=cdr args; if args then for each a in args do <<prin2la" , "; maprintla(a,0)>>; terpri(); prin2 "\right\}">> else prin2 "\{\}"; put('list,'laprifn,'listprla); put('arbint,'indexed,'(down)); put('arbreal,'indexed,'(down)); put('arbcomplex,'indexed,'(down)); algebraic; operator pdf,dint,product; endmodule; end;