Check-ins Using Download Hex

Artifact a3024dd53de8a856429183d79b848562b3acd74cf34770acab6e24680ac72f0b:

module mprint; % Basic output package for symbolic expressions.

% Authors: Anthony C. Hearn and Arthur C. Norman.

% Copyright (c) 1991 RAND.  All rights reserved.

fluid  '(!*fort
	 !*list
         !*nat
         !*nosplit
         !*ratpri
         !*revpri
	 bool!-functions!*
	 obrkp!*
         overflowed!*
         orig!*
	 outputhandler!*
         pline!*
         posn!*
	 p!*!*
	 testing!-width!*
         ycoord!*
         ymax!*
         ymin!*
         rprifn!* 
         rterfn!*);

fluid '(!*TeX);

global '(!*eraise initl!* nat!*!* spare!* !*asterisk);

switch list,ratpri,revpri,nosplit,asterisk;

% Global variables initialized in this section.

% SPARE!* should be set in the system dependent code module,
% but is now assumed to be zero.

!*asterisk := t;
!*eraise := t;
!*nat := nat!*!* := t;
!*nosplit := t;            % Expensive, maybe??
obrkp!* := t;
orig!*:=0;
posn!* := 0;
ycoord!* := 0;
ymax!* := 0;
ymin!* := 0;

initl!* := append('(orig!* pline!*),initl!*);

put('orig!*,'initl,0);

flag('(linelength),'opfn);  %to make it a symbolic operator;

symbolic procedure mathprint l;
   << terpri!* t;
      maprin l;
      terpri!* t >>;

symbolic procedure maprin u;
   if outputhandler!* then apply2(outputhandler!*,'maprin,u)
    else if not overflowed!* then maprint(u,0);

symbolic procedure maprint(l,p!*!*);
   % Print expression l at bracket level p!*!* without terminating
   % print line.  Special cases are handled by:
   %    pprifn: a print function that includes bracket level as 2nd arg.
   %     prifn: a print function with one argument.
   begin scalar p,x,y;
	p := p!*!*;     % p!*!* needed for (expt a (quotient ...)) case.
        if null l then return nil
	 else if atom l
	  then <<if vectorp l then vec!-maprin(l,p!*!*)
		  else if not numberp l
		     or (not(l<0) or p<=get('minus,'infix))
		   then prin2!* l
		  else <<prin2!* "("; prin2!* l; prin2!* ")">>;
		 return l >>
         else if not atom car l then maprint(car l,p)
         else if ((x := get(car l,'pprifn)) and
                   not(apply2(x,l,p) eq 'failed)) or
                 ((x := get(car l,'prifn)) and
                   not(apply1(x,l) eq 'failed))
	  then return l
	 else if x := get(car l,'infix) then <<
	   p := not(x>p);
           if p then <<
             y := orig!*;
	     prin2!* "(";
             orig!* := if posn!*<18 then posn!* else orig!*+3 >>;
% (expt a b) was dealt with using a pprifn sometime earlier than this
           inprint(car l,x,cdr l);
           if p then <<
	      prin2!* ")";
              orig!* := y >>;
           return l >>
         else prin2!* car l;
	prin2!* "(";
        obrkp!* := nil;
	y := orig!*;
	orig!* := if posn!*<18 then posn!* else orig!*+3;
        if cdr l then inprint('!*comma!*,0,cdr l);
        obrkp!* := t;
	orig!* := y;
	prin2!* ")";
        return l
    end;

symbolic procedure vec!-maprin(u,p!*!*);
   <<prin2!* '![;
     for j:=0:(upbv(u)-1)
	do <<maprint(getv(u,j),p!*!*); oprin '!*comma!*>>;
     maprint(getv(u,upbv(u)),p!*!*);
     prin2!* '!]>>;

symbolic procedure exptpri(l,p);
% Prints expression in an exponent notation.
   begin scalar !*list,x,pp,q,w1,w2;
      if not !*nat or !*fort then return 'failed;
      pp := not((q:=get('expt,'infix))>p);  % Need to parenthesize
      w1 := cadr l;
      w2 := caddr l;
      if !*eraise and not atom w1 and
         (x := get(car w1, 'prifn)) and
         get(x, 'expt) = 'inbrackets then
% Special treatment here to avoid muddle between exponents and
% raised indices
            w1 := layout!-formula(w1, 0, 'inbrackets)
% Very special treatment for things that will be displayed with
% subscripts
       else if x = 'indexprin and not (indexpower(w1, w2)='failed)
         then return nil
       else w1 := layout!-formula(w1, q, nil);
      if null w1 then return 'failed;
      begin scalar !*ratpri;
% I do not display fractions with fraction bars in exponent
% expressions, since it usually seems excessive. Also (-p)/q gets
% turned into -(p/q) for printing here
         if eqcar(w2,'quotient) and eqcar(cadr w2,'minus)
          then w2 := list('minus,list(car w2,cadadr w2,caddr w2))
          else w2 := negnumberchk w2;
         w2 := layout!-formula(w2, if !*eraise then 0 else q, nil)
      end;
      if null w2 then return 'failed;
      l := cdar w1 + cdar w2;
      if pp then l := l + 2;
      if l > linelength nil - spare!* - orig!* then return 'failed;
      if l > linelength nil - spare!* - posn!* then terpri!* t;
      if pp then prin2!* "(";
      putpline w1;
      if !*eraise then l := 1 - cadr w2
       else << oprin 'expt; l := 0 >>;
      putpline ((update!-pline(0, l, caar w2) . cdar w2) .
                ((cadr w2 + l) . (cddr w2 + l)));
      if pp then prin2!* ")"
   end;

put('expt,'pprifn,'exptpri);

symbolic procedure inprint(op,p,l);
   begin scalar x,y,z;
        if op='times and !*nat and null !*asterisk then
        <<op:='times2; put('times2,'infix,get('times,'infix));
          put('times2,'prtch," ")>>;
	if op eq 'plus and !*revpri then l := reverse l;
	    % print sum arguments in reverse order.
	if not get(op,'alt) then <<
	if op eq 'not then oprin op else
	  if op eq 'setq and not atom (x := car reverse l)
	     and idp car x and (y := getrtype x)
	     and (y := get(get(y,'tag),'setprifn))
	    then return apply2(y,car l,x);
	  if null atom car l and idp caar l
	      and !*nat and
	      ((x := get(caar l,'prifn)) or (x := get(caar l,'pprifn)))
              and (get(x,op) eq 'inbrackets)
            % to avoid mix up of indices and exponents.
	    then<<prin2!* "("; maprint(car l,p); prin2!* ")">>
           else if !*nosplit and not testing!-width!* then
                prinfit(car l, p, nil)
           else maprint(car l, p);
          l := cdr l >>;
        if !*nosplit and not testing!-width!* then
% The code here goes to a certain amount of trouble to try to arrange
% that terms are never split across lines. This will slow
% printing down a bit, but I hope the improvement in formatting will
% be worth that.
              for each v in l do
	       if atom v or not(op eq get(car v,'alt))
                then <<
% It seems to me that it looks nicer to put +, - etc on the second
% line, but := and comma usually look better on the first one when I
% need to split things.
		   if op memq '(setq !*comma!*) then <<
                      oprin op;
                      prinfit(negnumberchk v, p, nil) >>
                    else prinfit(negnumberchk v, p, op) >>
                else prinfit(v, p, nil)
         else for each v in l do <<
	       if atom v or not(op eq get(car v,'alt))
                then <<oprin op; maprint(negnumberchk v,p)>>
              % difficult problem of negative numbers needing to be in
              % prefix form for pattern matching.
               else maprint(v,p) >>
   end;

symbolic procedure flatsizec u;
   if null u then 0
    else if atom u then lengthc u
    else flatsizec car u + flatsizec cdr u + 1;

symbolic procedure oprin op;
   (lambda x;
         if null x then <<prin2!* " "; prin2!* op; prin2!* " ">>
          else if !*fort then prin2!* x
          else if !*list and obrkp!* and op memq '(plus minus)
           then if testing!-width!* then overflowed!* := t
                 else <<terpri!* t; prin2!* x>>
          else if flagp(op,'spaced)
           then <<prin2!* " "; prin2!* x; prin2!* " ">>
          else prin2!* x)
   get(op,'prtch);

symbolic procedure prin2!* u;
% The outputhandler!* test here is an ACN unilateral patch.
   if outputhandler!* then apply2(outputhandler!*,'prin2!*,u)
   else begin integer m,n,p; scalar x;
      if x := get(u,'oldnam) then u := x;
      if overflowed!* then return 'overflowed
      else if !*fort then return fprin2!* u
      else if !*nat then <<
	if u = 'pi then u := symbol '!.pi
	 else if u = 'infinity then u := symbol 'infinity>>;
      n := lengthc u;
      % Suggested by Wolfram Koepf:
      if fixp u and n>50 and !*rounded then return rd!:prin i2rd!* u;
      m := posn!* #+ n;
      p := linelength nil - spare!*;
      return if m<=p 
                or (not testing!-width!* 
       % The next line controls whether to add a newline before a long id.
       % At present it causes one in front of a number too.
                   and <<not fixp u and terpri!* t; (m := posn!* #+ n)<=p>>)
               then add_prin_char(u,m)
	     % Identifier longer than one line.
	      else if testing!-width!*
	       then <<overflowed!* := t;'overflowed>>
	      else prin2lint(u,posn!* #+ 1,p #- 1)
   end;

symbolic procedure add_prin_char(u,n);
   if null !*nat then if stringp u or get(u,'switch!*) or digit u
			or get(car explode2 u,'switch!*) then prin2 u
                       else prin1 u
    else <<pline!* := (((posn!* . n) . ycoord!*) . u) .  pline!*;
           posn!* := n>>;

symbolic procedure prin2lint(u,m,n);
   begin scalar v,bool;
      % bool prevents an initial backslash.
      v := explode2 u;
      if null !*nat then <<terpri(); posn!* := orig!*>>;
   a: if not(m#<n and v) then go to b
       else if car v eq !$eol!$ then <<v := cdr v; go to c>>;
      bool := t; add_prin_char(car v,m);
      v := cdr v; m := m #+ 1;
      go to a;
   b: if null v then return(posn!* := m #- 1)
       else if bool then add_prin_char("\",m);      
   c: if !*nat then terpri!* nil else <<terpri(); posn!* := orig!*>>;
      m := posn!* #+ 1;
      go to a
  end;

symbolic procedure terpri!* u;
   begin integer n;
	if outputhandler!* then return apply2(outputhandler!*,'terpri,u)
	 else if testing!-width!* then return overflowed!* := t
         else if !*fort then return fterpri(u)
	 else if !*nat and pline!*
	  then <<
           pline!* := reverse pline!*;
           for n := ymax!* step -1 until ymin!* do <<
             scprint(pline!*,n);
             terpri() >>;
           pline!* := nil >>;
	if u then terpri();
        posn!* := orig!*;
        ycoord!* := ymax!* := ymin!* := 0
   end;

symbolic procedure scprint(u,n);
   begin scalar m;
        posn!* := 0;
        for each v in u do <<
           if cdar v=n then <<
             if not((m:= caaar v-posn!*)<0) then spaces m;
             prin2 cdr v;
             posn!* := cdaar v >> >>
   end;


% Formatted printing of expressions.

% This one should be eliminated.

symbolic procedure writepri(u,v); assgnpri(eval u,nil,v);

symbolic procedure exppri(u,v); assgnpri(u,nil,v);

symbolic procedure assgnpri(u,v,w);
   begin scalar x;
   % U is expression being printed.
   % V is a list of expressions assigned to U.
   % W is an id that indicates if U is the first, only or last element
   %  in the current set (or NIL otherwise).
   % Returns NIL.
    testing!-width!* := overflowed!* := nil;
    if null u then u := 0;
    if !*nero and u=0 then return nil;
    % Special cases.  These tests need to be generalized.
    if !*TeX then return texpri(u,v,w)
     else if getd 'vecp and vecp u then return vecpri(u,'mat);
    if (x := getrtype u) and flagp(x,'sprifn) and null outputhandler!*
      then <<if null v then apply1(get(get(x,'tag),'prifn),u)
	       else maprin list('setq,car v,u); return nil>>;
    if w memq '(first only) then terpri!* t;
    v := evalvars v;    
    if !*fort then <<fvarpri(u,v,w); return nil>>;
    maprin if v then 'setq . aconc(v,u) else u;
    if null w or w eq 'first then return nil
     else if not !*nat then prin2!* "$";
    terpri!*(not !*nat);
    return nil
   end;

symbolic procedure evalvars u;
   % Used only in ASSGNPRI. We may need to expand the second test.
   % At the moment, it catches things like x-y:=0.
   if null u then nil
    else if atom car u or flagp(caar u,'intfn)
     then car u . evalvars cdr u
    else if get(get(caar u,'rtype),'setelemfn)
     then (caar u . revlis_without_mode cdar u) . evalvars cdr u
    else (caar u . revlis cdar u) . evalvars cdr u;

symbolic procedure revlis_without_mode u;
   for each j in u collect (reval j where dmode!* := nil);


% Definition of some symbols and their access function.

symbolic procedure symbol s;
   get(s,'symbol!-character);

put('!.pi, 'symbol!-character, 'pi);
put('bar, 'symbol!-character, '!-);
put('int!-top, 'symbol!-character, '!/);
put('int!-mid, 'symbol!-character, '!|);
put('int!-low, 'symbol!-character, '!/);
put('d, 'symbol!-character, '!d);       % This MUST be lower case
%%put('sqrt, 'symbol!-character, 'sqrt);% No useful fallback here
put('vbar, 'symbol!-character, '!|);
put('sum!-top, 'symbol!-character, "---");
put('sum!-mid, 'symbol!-character, ">  ");
put('sum!-low, 'symbol!-character, "---");
put('prod!-top, 'symbol!-character, "---");
put('prod!-mid, 'symbol!-character, "| |");
put('prod!-low, 'symbol!-character, "| |");
put('infinity, 'symbol!-character, 'infinity);
    % In effect nothing special

put('mat!-top!-l, 'symbol!-character, '![);
put('mat!-top!-r, 'symbol!-character, '!]);
put('mat!-low!-l, 'symbol!-character, '![);
put('mat!-low!-r, 'symbol!-character, '!]);


% The following definitions allow for more natural printing of
% conditional expressions within rule lists.

bool!-functions!* :=
  for each x in {'equal,'greaterp,'lessp,'geq,'leq,'neq,'numberp}
      collect get(x,'boolfn) . x;

symbolic procedure condpri(u,p);
   <<if p>0 then prin2!* "(";
     while (u := cdr u) do
        <<if not(caar u eq 't)
            then <<prin2!* 'if; prin2!* " "; 
                   maprin sublis(bool!-functions!*,caar u);
                   prin2!* " "; prin2!* 'then; prin2!* " ">>;
          maprin cadar u;
          if cdr u then <<prin2!* " "; prin2!* 'else; prin2!* " ">>>>;
     if p>0 then prin2!* ")">>;

put('cond,'pprifn,'condpri);

symbolic procedure revalpri u;
   maprin eval cadr u;

put('aeval,'prifn,'revalpri);

put('reval,'prifn,'revalpri);

symbolic procedure boolvalpri u;
   maprin cadr u;

put('boolvalue!*,'prifn,'boolvalpri);

put('prog,'prifn,'progpri);

put('progn,'prifn,'progpri);

symbolic procedure progpri u;
   (rprint u) where rprifn!* = 'prin2!*, 
       rterfn!* = function(lambda();terpri!* nil);
     
endmodule;

end;
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]