1module fmprint; % Fancy output package for symbolic expressions.
2                % using TEX as intermediate language.
3
4% Author: Herbert Melenk, using ideas of maprin.red (A.C.H, A.C.N).
5
6% Modifications:
7%               fancy!-mode!* commented out, since it applies only to
8%               very old versions. /
9
10% Copyright (c) 2003 Anthony C. Hearn, Konrad-Zuse-Zentrum.
11%           All rights reserved.
12
13% Redistribution and use in source and binary forms, with or without
14% modification, are permitted provided that the following conditions are met:
15%
16%    * Redistributions of source code must retain the relevant copyright
17%      notice, this list of conditions and the following disclaimer.
18%    * Redistributions in binary form must reproduce the above copyright
19%      notice, this list of conditions and the following disclaimer in the
20%      documentation and/or other materials provided with the distribution.
21%
22% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
24% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
25% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
26% CONTRIBUTORS
27% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
28% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
29% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
30% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
31% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
32% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33% POSSIBILITY OF SUCH DAMAGE.
34%
35
36
37%   8-Sep-94
38%               introduced data driven formatting (print-format)
39
40%  12-Apr-94
41%               removed print function for dfp
42%               removed some unused local variables
43%               corrected output for conditional expressions and
44%                 aeval/aeval* forms
45
46%  17_Mar-94    corrected line breaks in Taylor expressions
47%               rational exponents use /
48%               vertical bar for SUB expressions
49%               explicit * for product of two quotients (Taylor)
50
51% switches
52%
53%    ON FANCY          enable algebraic output processing by this module
54%
55%    ON FANCY_TEX      under ON FANCY: display TEX equivalent
56%
57
58% properties used in this module:
59%
60%     fancy-prifn      print function for an operator
61%
62%     fancy-pprifn     print function for an operator including current
63%                      operator precedence for infix printing
64%
65%     fancy!-flatprifn print function for objects which require
66%                      special printing if prefix operator form
67%                      would have been used, e.g. matrix, list
68%
69%     fancy-prtch      string for infix printing of an operator
70%
71%     fancy-special-symbol
72%                      print expression for a non-indexed item
73%                      string with TEX expression  "\alpha"
74%                         or
75%                      number referring ASCII symbol code
76%
77%     fancy-infix-symbol    special-symbol for infix operators
78%
79%     fancy-prefix-symbol   special symbol for prefix operators
80%
81%     fancy!-symbol!-length  the number of horizontal units needed for
82%                      the symbol.  A standard character has 2 units.
83
84
85%  94-Jan-26 - Output for Taylor series repaired.
86%  94-Jan-17 - printing of index for Bessel function repaired.
87%            - New functions for local encapsulation of printing
88%              independent of inline fancy!-level.
89%            - Allow printing of upper case symbols locally
90%              controlled by *fancy-lower
91
92%  93-Dec-22 Vectors printed with square brackets.
93
94create!-package('(fmprint),nil);
95
96fluid  '(
97         !*list
98         !*nat
99         !*nosplit
100         !*ratpri
101         !*revpri
102         overflowed!*
103         p!*!*
104         testing!-width!*
105         tablevel!*
106         sumlevel!*
107         outputhandler!*
108         outputhandler!-stack!*
109         posn!*
110         obrkp!*    % outside-brackets-p
111         );
112
113global '(!*eraise charassoc!* initl!* nat!*!* spare!* ofl!*);
114
115switch list,ratpri,revpri,nosplit;
116
117% Global variables initialized in this section.
118
119fluid '(
120      fancy!-switch!-on!*
121      fancy!-switch!-off!*
122      !*fancy!-mode
123      fancy!-pos!*
124      fancy!-line!*
125      fancy!-page!*
126      fancy!-bstack!*
127      !*fancy_tex
128      !*fancy!-lower    % control of conversion to lower case
129      );
130
131fluid '(fancy!-texpos);
132
133switch fancy_tex; % output TEX equivalent.
134
135fancy!-switch!-on!* := int2id 16$
136fancy!-switch!-off!* := int2id 17$
137!*fancy!-lower := t;
138
139global '(fancy_lower_digits fancy_print_df);
140
141share fancy_lower_digits; % T, NIL or ALL.
142
143if null fancy_lower_digits then fancy_lower_digits:=t;
144
145share fancy_print_df;     % PARTIAL, TOTAL, INDEXED.
146
147if null fancy_print_df then  fancy_print_df := 'partial;
148switch fancy;
149
150put('fancy,'simpfg,
151  '((t (fmp!-switch t))
152    (nil (fmp!-switch nil)) ));
153
154
155symbolic procedure fmp!-switch mode;
156      if mode then
157        <<if outputhandler!* neq 'fancy!-output then
158          <<outputhandler!-stack!* :=
159                outputhandler!* . outputhandler!-stack!*;
160           outputhandler!* := 'fancy!-output;
161          >>;
162          !*fancy := t
163        >>
164      else
165        <<if outputhandler!* = 'fancy!-output then
166          <<outputhandler!* := car outputhandler!-stack!*;
167            outputhandler!-stack!* := cdr outputhandler!-stack!*;
168            !*fancy := nil
169          >>
170	  else
171          << !*fancy := nil;
172             rederr "FANCY is not current output handler" >>
173% ACN feels that raising an error on an attempt to switch off an option
174% in the case that the option is already disabled is a bit harsh.
175        >>;
176
177symbolic procedure fancy!-out!-header();
178    if not !*fancy_tex then prin2 fancy!-switch!-on!*;
179
180symbolic procedure fancy!-out!-trailer();
181  <<if not !*fancy_tex then prin2 fancy!-switch!-off!*;
182     terpri()>>;
183
184symbolic procedure fancy!-tex s;
185  % test output: print tex string.
186   <<prin2 fancy!-switch!-on!*;
187     for each x in explode2 s do prin2 x;
188     prin2t fancy!-switch!-off!*;
189   >>;
190
191symbolic procedure fancy!-out!-item(it);
192  if atom it then prin2 it else
193  if eqcar(it,'ascii) then writechar(cadr it) else
194  if eqcar(it,'tab) then
195     for i:=1:cdr it do prin2 "\>"
196    else
197  if eqcar(it,'bkt) then
198     begin scalar m,b,l; integer n;
199      m:=cadr it; b:=caddr it; n:=cadddr it;
200      l := b member '( !( !{ );
201   %  if m then prin2 if l then "\left" else "\right"
202   % else
203      if n> 0 then
204      <<prin2 if n=1 then "\big" else if n=2 then "\Big" else
205             if n=3 then "\bigg" else "\Bigg";
206        prin2 if l then "l" else "r";
207      >>;
208      if b member '(!{ !}) then prin2 "\";
209      prin2 b;
210    end
211    else
212      rederr "unknown print item";
213
214symbolic procedure set!-fancymode bool;
215  if bool neq !*fancy!-mode then
216    <<!*fancy!-mode:=bool;
217      fancy!-pos!* :=0;
218      fancy!-texpos:=0;
219      fancy!-page!*:=nil;
220      fancy!-line!*:=nil;
221      overflowed!* := nil;
222        % new: with tab
223      fancy!-line!*:= '((tab . 1));
224      fancy!-pos!* := 10;
225      sumlevel!* := tablevel!* := 1;
226   >>;
227
228symbolic procedure fancy!-output(mode,l);
229  % Interface routine.
230  if ofl!* or posn!*>2 or not !*nat then
231     % not terminal handler or current output line non-empty.
232   <<if mode = 'maprin then maprin l
233     else
234     terpri!*(l)
235   >> where outputhandler!* = nil
236     else
237   <<set!-fancymode t;
238     if mode = 'maprin then fancy!-maprin0 l
239     else if mode = 'assgnpri then << fancy!-assgnpri l; fancy!-flush() >>
240     else
241     fancy!-flush();
242    >>;
243
244% fancy!-assignpri checks whether a special printing function is defined
245% and calls it
246symbolic procedure fancy!-assgnpri u;
247   begin scalar x,y;
248     x := getrtype car u;
249     y := get(get(x,'tag),'fancy!-assgnpri);
250     return if y then apply1(y,u) else fancy!-maprin0 car u
251  end;
252
253
254symbolic procedure fancy!-flush();
255    << fancy!-terpri!* t;
256        for each line in reverse fancy!-page!* do
257        if line and not eqcar(car line,'tab) then
258        <<fancy!-out!-header();
259          for each it in reverse line do fancy!-out!-item it;
260          fancy!-out!-trailer();
261        >>;
262        set!-fancymode nil;
263      >> where !*lower=nil;
264
265%---------------- primitives -----------------------------------
266
267symbolic procedure fancy!-special!-symbol(u,n);
268   if numberp u then
269     <<fancy!-prin2!*("\symb{",n);
270       fancy!-prin2!*(u,0);
271       fancy!-prin2!*("}",0);
272     >>
273    else fancy!-prin2!*(u,n);
274
275symbolic procedure fancy!-prin2 u;
276    fancy!-prin2!*(u,nil);
277
278symbolic procedure fancy!-prin2!*(u,n);
279  if numberp u and not testing!-width!* then fancy!-prin2number u
280     else
281  (begin scalar str,id; integer l;
282    str := stringp u; id := idp u and not digit u;
283    u:= if atom u then explode2 u where !*lower=!*fancy!-lower
284        else {u};
285    l := if numberp n then n else 2*length u;
286    if id and not numberp n then
287       u:=fancy!-lower!-digits(fancy!-esc u);
288    for each x in u do
289    <<if str and (x='!    or x='!_)
290         then fancy!-line!* := '!\ . fancy!-line!*;
291      fancy!-line!* :=
292        (if id and !*fancy!-lower
293          then red!-char!-downcase x else x) . fancy!-line!*;
294    >>;
295    fancy!-pos!* := fancy!-pos!* + l;
296    if fancy!-pos!* > 2 * (linelength nil +1 ) then overflowed!*:=t;
297  end) where !*lower = !*lower;
298
299symbolic procedure fancy!-last!-symbol();
300   if fancy!-line!* then car fancy!-line!*;
301
302charassoc!* :=
303         '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e) (!F . !f)
304           (!G . !g) (!H . !h) (!I . !i) (!J . !j) (!K . !k) (!L . !l)
305           (!M . !m) (!N . !n) (!O . !o) (!P . !p) (!Q . !q) (!R . !r)
306           (!S . !s) (!T . !t) (!U . !u) (!V . !v) (!W . !w) (!X . !x)
307           (!Y . !y) (!Z . !z));
308
309symbolic procedure red!-char!-downcase u;
310   (if x then cdr x else u) where x = atsoc(u,charassoc!*);
311
312symbolic procedure fancy!-prin2number u;
313  % we print a number eventually causing a line break
314  % for very big numbers.
315  if testing!-width!* then  fancy!-prin2!*(u,t) else
316     fancy!-prin2number1 (if atom u then explode2 u else u);
317
318symbolic procedure fancy!-prin2number1 u;
319  begin integer c,ll;
320   ll := 2 * (linelength nil +1 );
321   while u do
322   <<c:=c+1;
323     if c>10 and fancy!-pos!* > ll then fancy!-terpri!*(t);
324     fancy!-prin2!*(car u,2); u:=cdr u;
325   >>;
326  end;
327
328symbolic procedure fancy!-esc u;
329   if not('!_ memq u) then u else
330   (if car u eq '!_ then '!\ . w else w)
331      where w = car u . fancy!-esc cdr u;
332
333symbolic procedure fancy!-lower!-digits u;
334    (if null m then u else if m = 'all or
335        fancy!-lower!-digitstrail(u,nil) then
336           fancy!-lower!-digits1(u,nil)
337     else u
338     ) where m=fancy!-mode 'fancy_lower_digits;
339
340symbolic procedure fancy!-lower!-digits1(u,s);
341  begin scalar c,q,r,w,x;
342 loop:
343    if u then <<c:=car u; u:=cdr u>> else c:=nil;
344    if null s then
345      if not digit c and c then w:=c.w else
346      << % need to close the symbol w;
347         w:=reversip w;
348         q:=intern compress w;
349         if stringp (x:=get(q,'fancy!-special!-symbol))
350            then w:=explode2 x;
351         r:=nconc(r,w);
352         if digit c then <<s:=t; w:={c}>> else w:=nil;
353      >>
354    else
355      if digit c then w:=c.w else
356      << % need to close the number w.
357        w:='!_ . '!{ . reversip('!} . w);
358        r:=nconc(r,w);
359        if c then <<s:=nil; w:={c}>> else w:=nil;
360      >>;
361    if w then goto loop;
362    return r;
363  end;
364
365
366
367
368symbolic procedure fancy!-lower!-digitstrail(u,s);
369   if null u then s else
370   if not s and digit car u then
371          fancy!-lower!-digitstrail(cdr u,t) else
372   if s and not digit car u then nil
373   else fancy!-lower!-digitstrail(cdr u,s);
374
375symbolic procedure fancy!-terpri!* u;
376   <<
377     if fancy!-line!* then
378         fancy!-page!* := fancy!-line!* . fancy!-page!*;
379     fancy!-pos!* :=tablevel!* * 10;
380     fancy!-texpos := tablevel!* * 30000; % Roughtly 1 cm
381     fancy!-line!*:= {'tab . tablevel!*};
382     overflowed!* := nil
383   >>;
384
385% Moved to alg/general.red so that independent modules can implement
386% their own custom printing schemes more easily.
387%
388%symbolic macro procedure fancy!-level u;
389% % unwind-protect for special output functions.
390%  {'prog,'(pos fl w),
391%      '(setq pos fancy!-pos!*),
392%      '(setq fl fancy!-line!*),
393%      {'setq,'w,cadr u},
394%      '(cond ((eq w 'failed)
395%              (setq fancy!-line!* fl)
396%              (setq fancy!-pos!* pos))),
397%       '(return w)};
398
399symbolic procedure fancy!-begin();
400  % collect current status of fancy output. Return as a list
401  % for later recovery.
402  {fancy!-pos!*,fancy!-line!*,fancy!-texpos};
403
404symbolic procedure fancy!-end(r,s);
405  % terminates a fancy print sequence. Eventually resets
406  % the output status from status record <s> if the result <r>
407  % signals an overflow.
408  <<if r='failed then
409     <<fancy!-line!*:=car s; fancy!-pos!*:=cadr s;fancy!-texpos:=caddr s>>;
410     r>>;
411
412symbolic procedure fancy!-mode u;
413  begin scalar m;
414     m:= lispeval u;
415     if eqcar(m,'!*sq) then m:=reval m;
416     return m;
417  end;
418
419%---------------- central formula converter --------------------
420
421symbolic procedure fancy!-maprin0 u;
422   if not overflowed!* then fancy!-maprint(u,0) where !*lower=nil;
423
424symbolic procedure fancy!-maprint(l,p!*!*);
425   % Print expression l at bracket level p!*!* without terminating
426   % print line.  Special cases are handled by:
427   %    pprifn: a print function that includes bracket level as 2nd arg.
428   %     prifn: a print function with one argument.
429  (begin scalar p,x,w,pos,tpos, fl;
430        p := p!*!*;     % p!*!* needed for (expt a (quotient ...)) case.
431        if null l then return nil;
432        if atom l then return fancy!-maprint!-atom(l,p);
433        pos := fancy!-pos!*; tpos := fancy!-texpos; fl := fancy!-line!*;
434
435        if not atom car l then return fancy!-maprint(car l,p);
436
437        l := fancy!-convert(l,nil);
438
439        if (x:=get(car l,'fancy!-reform)) then
440          return fancy!-maprint(apply1(x,l),p);
441        if ((x := get(car l,'fancy!-pprifn)) and
442                   not(apply2(x,l,p) eq 'failed))
443          or ((x := get(car l,'fancy!-prifn)) and
444                   not(apply1(x,l) eq 'failed))
445          or (get(car l,'print!-format)
446                 and fancy!-print!-format(l,p) neq 'failed)
447          then return nil;
448
449        if testing!-width!* and overflowed!*
450           or w='failed then return fancy!-fail(pos,tpos,fl);
451
452        % eventually convert expression to a different form
453        % for printing.
454
455        l := fancy!-convert(l,'infix);
456
457        % printing operators with integer argument in index form.
458        if flagp(car l,'print!-indexed) then
459        << fancy!-prefix!-operator(car l);
460           w :=fancy!-print!-indexlist cdr l
461        >>
462
463        else if x := get(car l,'infix) then
464        << p := not(x>p);
465          w:= if p then fancy!-in!-brackets(
466            {'fancy!-inprint,mkquote car l,x,mkquote cdr l},
467               '!(,'!))
468              else
469            fancy!-inprint(car l,x,cdr l);
470        >>
471        else if x:= get(car l,'fancy!-flatprifn) then
472            w:=apply(x,{l})
473        else
474        <<
475           w:=fancy!-prefix!-operator(car l);
476           obrkp!* := nil;
477           if w neq 'failed then
478             w:=fancy!-print!-function!-arguments cdr l;
479        >>;
480
481        return if testing!-width!* and overflowed!*
482              or w='failed then fancy!-fail(pos,tpos,fl) else nil;
483    end ) where obrkp!*=obrkp!*;
484
485symbolic procedure fancy!-convert(l,m);
486  % special converters.
487  if eqcar(l,'expt) and cadr l= 'e and
488     ( m='infix or treesizep(l,20) )
489        then {'exp,caddr l}
490    else l;
491
492symbolic procedure fancy!-print!-function!-arguments u;
493  % u is a parameter list for a function.
494    fancy!-in!-brackets(
495       u and {'fancy!-inprint, mkquote '!*comma!*,0,mkquote u},
496            '!(,'!));
497
498symbolic procedure fancy!-maprint!-atom(l,p);
499 fancy!-level
500  begin scalar x;
501     if(x:=get(l,'fancy!-special!-symbol))
502           then fancy!-special!-symbol(x,
503                get(l,'fancy!-special!-symbol!-size) or 2)
504     else
505     if vectorp l then
506       <<fancy!-prin2!*("[",0);
507         l:=for i:=0:upbv l collect getv(l,i);
508         x:=fancy!-inprint(",",0,l);
509         fancy!-prin2!*("]",0);
510        return x>>
511     else
512     if not numberp l or (not (l<0) or p<=get('minus,'infix))
513         then fancy!-prin2!*(l,'index)
514     else
515     fancy!-in!-brackets(
516          {'fancy!-prin2!*,mkquote l,t}, '!(,'!));
517     return if testing!-width!* and overflowed!* then 'failed
518              else nil;
519  end;
520
521put('print_indexed,'psopfn,'(lambda(u)(flag u 'print!-indexed)));
522
523symbolic procedure fancy!-print!-indexlist l;
524   fancy!-print!-indexlist1(l,'!_,nil);
525
526symbolic procedure fancy!-print!-indexlist1(l,op,sep);
527  % print index or exponent lists, with or without separator.
528 fancy!-level
529  begin scalar w,testing!-width!*,obrkp!*;
530    testing!-width!* :=t;
531    fancy!-prin2!*(op,0);
532    fancy!-prin2!*('!{,0);
533    if null l then w:=nil
534      else w:=fancy!-inprint(sep or 'times,0,l);
535    fancy!-prin2!*("}",0);
536    return w;
537  end;
538
539symbolic procedure fancy!-print!-one!-index i;
540 fancy!-level
541  begin scalar w,testing!-width!*,obrkp!*;
542    testing!-width!* :=t;
543    fancy!-prin2!*('!_,0);
544    fancy!-prin2!*('!{,0);
545    w:=fancy!-inprint('times,0,{i});
546    fancy!-prin2!*("}",0);
547    return w;
548  end;
549
550symbolic procedure fancy!-in!-brackets(u,l,r);
551  % put form into brackets (round, curly,...).
552  % u: form to be evaluated,
553  % l,r: left and right brackets to be inserted.
554  fancy!-level
555   (begin scalar fp,w,r1,r2,rec;
556     rec := {0};
557     fancy!-bstack!* := rec . fancy!-bstack!*;
558     fancy!-adjust!-bkt!-levels fancy!-bstack!*;
559     fp := length fancy!-page!*;
560     fancy!-prin2!* (r1:='bkt.nil.l.rec, 2);
561     w := eval u;
562     fancy!-prin2!* (r2:='bkt.nil.r.rec, 2);
563       % no line break: use \left( .. \right) pair.
564     if fp = length fancy!-page!* then
565     <<car cdr r1:= t; car cdr r2:= t>>;
566     return w;
567   end)
568    where fancy!-bstack!* = fancy!-bstack!*;
569
570
571symbolic procedure fancy!-adjust!-bkt!-levels u;
572   if null u or null cdr u then nil
573   else if caar u >= caadr u then
574    <<car cadr u := car cadr u +1;
575      fancy!-adjust!-bkt!-levels cdr u; >>;
576
577symbolic procedure fancy!-exptpri(l,p);
578% Prints expression in an exponent notation.
579   (begin scalar !*list,pp,q,w,w1,w2,pos,tpos,fl;
580      pos:=fancy!-pos!*; tpos:=fancy!-texpos; fl:=fancy!-line!*;
581      pp := not((q:=get('expt,'infix))>p);  % Need to parenthesize
582      w1 := cadr l; w2 := caddr l;
583      testing!-width!* := t;
584      if eqcar(w2,'quotient) and cadr w2 = 1
585          and (fixp caddr w2 or liter caddr w2) then
586         return fancy!-sqrtpri!*(w1,caddr w2);
587      if eqcar(w2,'quotient) and eqcar(cadr w2,'minus)
588          then w2 := list('minus,list(car w2,cadadr w2,caddr w2))
589          else w2 := negnumberchk w2;
590      if fancy!-maprint(w1,q)='failed
591            then return fancy!-fail(pos,tpos,fl);
592     fancy!-prin2!*("^",0);
593     if eqcar(w2,'quotient) and fixp cadr w2 and fixp caddr w2 then
594      <<fancy!-prin2!*("{",0); w:=fancy!-inprint('!/,0,cdr w2);
595                 fancy!-prin2!*("}",0)>>
596           else w:=fancy!-maprint!-tex!-bkt(w2,0,nil);
597     if w='failed then return fancy!-fail(pos,tpos,fl) ;
598    end) where !*ratpri=!*ratpri,
599           testing!-width!*=testing!-width!*;
600
601put('expt,'fancy!-pprifn,'fancy!-exptpri);
602
603symbolic procedure fancy!-inprint(op,p,l);
604  (begin scalar x,y,w, pos,tpos,fl;
605     pos:=fancy!-pos!*;
606     tpos:= fancy!-texpos;
607     fl:=fancy!-line!*;
608      % print product of quotients using *.
609     if op = 'times and eqcar(car l,'quotient) and
610       cdr l and eqcar(cadr l,'quotient) then
611        op:='!*;
612     if op eq 'plus and !*revpri then l := reverse l;
613     if not get(op,'alt) then
614     <<
615        if op eq 'not then
616         << fancy!-oprin op;
617            return  fancy!-maprint(car l,get('not,'infix));
618         >>;
619        if op eq 'setq and not atom (x := car reverse l)
620             and idp car x and (y := getrtype x)
621             and (y := get(get(y,'tag),'fancy!-setprifn))
622            then return apply2(y,car l,x);
623        if not atom car l and idp caar l
624              and
625           ((x := get(caar l,'fancy!-prifn))
626                   or (x := get(caar l,'fancy!-pprifn)))
627              and (get(x,op) eq 'inbrackets)
628            % to avoid mix up of indices and exponents.
629          then<<
630               fancy!-in!-brackets(
631                {'fancy!-maprint,mkquote car l,p}, '!(,'!));
632              >>
633           else if !*nosplit and not testing!-width!* then
634                fancy!-prinfit(car l, p, nil)
635           else w:=fancy!-maprint(car l, p);
636          l := cdr l
637      >>;
638     if testing!-width!* and (overflowed!* or w='failed)
639            then return fancy!-fail(pos,tpos,fl);
640     if !*list and obrkp!* and memq(op,'(plus minus)) then
641        <<sumlevel!*:=sumlevel!*+1;
642          tablevel!* := tablevel!* + 1>>;
643     if !*nosplit and not testing!-width!* then
644          % main line:
645         fancy!-inprint1(op,p,l)
646     else w:=fancy!-inprint2(op,p,l);
647     if testing!-width!* and w='failed then return fancy!-fail(pos,tpos,fl);
648   end
649   ) where tablevel!*=tablevel!*, sumlevel!*=sumlevel!*;
650
651
652symbolic procedure fancy!-inprint1(op,p,l);
653   % main line (top level) infix printing, allow line break;
654  begin scalar lop,space;
655   space := flagp(op,'spaced);
656   for each v in l do
657   <<lop := op;
658     if op='plus and eqcar(v,'minus) then
659       <<lop := 'minus; v:= cadr v; p:=get('minus,'infix)>>;
660     if space then fancy!-prin2!*("\,",1);
661     if 'failed = fancy!-oprin lop then
662      <<fancy!-terpri!* nil; fancy!-oprin lop>>;
663     if space then fancy!-prin2!*("\,",1);
664     fancy!-prinfit(negnumberchk v, p, nil)
665   >>;
666  end;
667
668symbolic procedure fancy!-inprint2(op,p,l);
669   % second line
670  begin scalar lop,space,w;
671   space := flagp(op,'spaced);
672   for each v in l do
673    if not testing!-width!* or w neq 'failed then
674     <<lop:=op;
675       if op='plus and eqcar(v,'minus) then
676              <<lop := 'minus; v:= cadr v; p:=get('minus,'infix)>>;
677       if space then fancy!-prin2!*("\,",1);
678       fancy!-oprin lop;
679       if space then fancy!-prin2!*("\,",1);
680       if w neq 'failed then w:=fancy!-maprint(negnumberchk v,p)
681     >>;
682   return w;
683  end;
684
685symbolic procedure fancy!-inprintlist(op,p,l);
686   % inside algebraic list
687fancy!-level
688 begin scalar fst,w,v;
689  loop:
690   if null l then return w;
691   v := car l; l:= cdr l;
692   if fst then
693       << fancy!-prin2!*("\,",1);
694          w:=fancy!-oprin op;
695          fancy!-prin2!*("\,",1);
696       >>;
697   if w eq 'failed  and testing!-width!* then return w;
698   w:= if w eq 'failed then fancy!-prinfit(v,0,op)
699                    else fancy!-prinfit(v,0,nil);
700   if w eq 'failed  and testing!-width!* then return w;
701   fst := t;
702   goto loop;
703  end;
704
705put('times,'fancy!-prtch,"\,");
706
707symbolic procedure fancy!-oprin op;
708 fancy!-level
709  begin scalar x;
710    if (x:=get(op,'fancy!-prtch)) then fancy!-prin2!*(x,1)
711      else
712    if (x:=get(op,'fancy!-infix!-symbol))
713           then fancy!-special!-symbol(x,get(op,'fancy!-symbol!-length)
714                                            or 4)
715      else
716    if null(x:=get(op,'prtch)) then fancy!-prin2!*(op,t)
717      else
718    << if !*list and obrkp!* and op memq '(plus minus)
719        and sumlevel!*=2
720       then
721        if testing!-width!* then return 'failed
722            else fancy!-terpri!* t;
723       fancy!-prin2!*(x,t);
724    >>;
725    if overflowed!* then return 'failed
726   end;
727
728put('alpha,'fancy!-special!-symbol,"\alpha");
729put('beta,'fancy!-special!-symbol,"\beta");
730put('gamma,'fancy!-special!-symbol,"\Gamma");
731put('delta,'fancy!-special!-symbol,"\delta");
732put('epsilon,'fancy!-special!-symbol,"\epsilon");
733put('zeta,'fancy!-special!-symbol,"\zeta");
734put('eta,'fancy!-special!-symbol,"\eta");
735put('theta,'fancy!-special!-symbol,"\theta");
736put('iota,'fancy!-special!-symbol,"\iota");
737put('kappa,'fancy!-special!-symbol,"\kappa");
738put('lambda,'fancy!-special!-symbol,"\lambda");
739put('mu,'fancy!-special!-symbol,"\mu");
740put('nu,'fancy!-special!-symbol,"\nu");
741put('xi,'fancy!-special!-symbol,"\xi");
742put('pi,'fancy!-special!-symbol,"\pi");
743put('rho,'fancy!-special!-symbol,"\rho");
744put('sigma,'fancy!-special!-symbol,"\sigma");
745put('tau,'fancy!-special!-symbol,"\tau");
746put('upsilon,'fancy!-special!-symbol,"\upsilon");
747put('phi,'fancy!-special!-symbol,"\phi");
748put('chi,'fancy!-special!-symbol,"\chi");
749put('psi,'fancy!-special!-symbol,"\psi");
750put('omega,'fancy!-special!-symbol,"\omega");
751
752if 'a neq '!A then deflist('(
753    (!Alpha 65) (!Beta 66) (!Chi 67) (!Delta 68)
754    (!Epsilon 69)(!Phi 70) (!Gamma 71)(!Eta 72)
755    (!Iota 73) (!vartheta 74)(!Kappa 75)(!Lambda 76)
756    (!Mu 77)(!Nu 78)(!O 79)(!Pi 80)(!Theta 81)
757    (!Rho 82)(!Sigma 83)(!Tau 84)(!Upsilon 85)
758    (!Omega 87) (!Xi 88)(!Psi 89)(!Zeta 90)
759    (!varphi 106)
760       ),'fancy!-special!-symbol);
761
762put('infinity,'fancy!-special!-symbol,"\infty");
763
764% some symbols form the upper ASCII part of the symbol font
765
766put('partial!-df,'fancy!-special!-symbol,182);
767put('partial!-df,'fancy!-symbol!-length,8);
768put('empty!-set,'fancy!-special!-symbol,198);
769put('not,'fancy!-special!-symbol,216);
770put('not,'fancy!-infix!-symbol,216);
771
772 % symbols as infix opertors
773put('leq,'fancy!-infix!-symbol,163);
774put('geq,'fancy!-infix!-symbol,179);
775put('neq,'fancy!-infix!-symbol,185);
776put('intersection,'fancy!-infix!-symbol,199);
777put('union,'fancy!-infix!-symbol,200);
778put('member,'fancy!-infix!-symbol,206);
779put('and,'fancy!-infix!-symbol,217);
780put('or,'fancy!-infix!-symbol,218);
781put('when,'fancy!-infix!-symbol,239);
782put('!*wcomma!*,'fancy!-infix!-symbol,",\,");
783
784put('replaceby,'fancy!-infix!-symbol,222);
785put('replaceby,'fancy!-symbol!-length,8);
786
787 % symbols as prefix functions
788put('gamma,'fancy!-functionsymbol,71);  % big Gamma
789%
790put('!~,'fancy!-functionsymbol,34);     % forall
791put('!~,'fancy!-symbol!-length,8);
792
793 % arbint, arbcomplex.
794put('arbcomplex,'fancy!-functionsymbol,227);
795put('arbint,'fancy!-functionsymbol,226);
796
797flag('(arbcomplex arbint),'print!-indexed);
798
799% flag('(delta),'print!-indexed);         % Dirac delta symbol.
800% David Hartley voted against..
801
802% The following definitions allow for more natural printing of
803% conditional expressions within rule lists.
804
805symbolic procedure fancy!-condpri0 u;
806   fancy!-condpri(u,0);
807
808symbolic procedure fancy!-condpri(u,p);
809 fancy!-level
810  begin scalar w;
811    if p>0 then fancy!-prin2 "\bigl(";
812    while (u := cdr u) and w neq 'failed do
813      <<if not(caar u eq 't)
814            then <<fancy!-prin2 'if; fancy!-prin2 " ";
815                   w:=fancy!-maprin0 caar u;
816                   fancy!-prin2 "\,"; fancy!-prin2 'then;
817                   fancy!-prin2 "\,">>;
818          if w neq 'failed then w := fancy!-maprin0 cadar u;
819          if cdr u then <<fancy!-prin2 "\,";
820                       fancy!-prin2 'else; fancy!-prin2 "\,">>>>;
821     if p>0 then fancy!-prin2 "\bigr)";
822     if overflowed!* or w='failed then return 'failed;
823   end;
824
825put('cond,'fancy!-pprifn,'fancy!-condpri);
826put('cond,'fancy!-flatprifn,'fancy!-condpri0);
827
828symbolic procedure fancy!-revalpri u;
829   fancy!-maprin0 fancy!-unquote cadr u;
830
831symbolic procedure fancy!-unquote u;
832  if eqcar(u,'list) then for each x in cdr u collect
833      fancy!-unquote x
834  else if eqcar(u,'quote) then cadr u else u;
835
836put('aeval,'fancy!-prifn,'fancy!-revalpri);
837put('aeval!*,'fancy!-prifn,'fancy!-revalpri);
838put('reval,'fancy!-prifn,'fancy!-revalpri);
839put('reval!*,'fancy!-prifn,'fancy!-revalpri);
840
841put('aminusp!:,'fancy!-prifn,'fancy!-patpri);
842put('aminusp!:,'fancy!-pat,'(lessp !&1 0));
843
844symbolic procedure fancy!-holdpri u;
845   if atom cadr u then fancy!-maprin0 cadr u
846   else fancy!-in!-brackets({'fancy!-maprin0, mkquote cadr u}, '!(, '!));
847
848put('!*hold, 'fancy!-prifn, 'fancy!-holdpri);
849
850symbolic procedure fancy!-patpri u;
851  begin scalar p;
852    p:=subst(fancy!-unquote  cadr u,'!&1,
853             get(car u,'fancy!-pat));
854    return fancy!-maprin0 p;
855  end;
856
857symbolic procedure fancy!-boolvalpri u;
858   fancy!-maprin0 cadr u;
859
860put('boolvalue!*,'fancy!-prifn,'fancy!-boolvalpri);
861
862symbolic procedure fancy!-quotpri u;
863   begin scalar n1,n2,n1t,n2t,fl,w,pos,tpos,testing!-width!*,!*list;
864     if overflowed!* then return 'failed;
865     testing!-width!*:=t;
866     pos:=fancy!-pos!*;
867     tpos:=fancy!-texpos;
868     fl:=fancy!-line!*;
869     fancy!-prin2!*("\frac",0);
870     w:=fancy!-maprint!-tex!-bkt(cadr u,0,t);
871     n1 := fancy!-pos!*;
872     n1t := fancy!-texpos;
873     if w='failed
874       then return fancy!-fail(pos,tpos,fl);
875     fancy!-pos!* := pos;
876     fancy!-texpos := tpos;
877     w := fancy!-maprint!-tex!-bkt(caddr u,0,t);
878     n2 := fancy!-pos!*;
879     n2t := fancy!-texpos;
880     if w='failed
881       then return fancy!-fail(pos,tpos,fl);
882     fancy!-pos!* := max(n1,n2);
883     fancy!-texpos := max(n1t,n2t);
884     return t;
885  end;
886
887symbolic procedure fancy!-maprint!-tex!-bkt(u,p,m);
888  % Produce expression with tex brackets {...} if
889  % necessary. Ensure that {} unit is in same formula.
890  % If m=t brackets will be inserted in any case.
891  begin scalar w,pos,tpos,fl,testing!-width!*;
892    testing!-width!*:=t;
893    pos:=fancy!-pos!*;
894    tpos:=fancy!-texpos;
895    fl:=fancy!-line!*;
896   if not m and (numberp u and 0<=u and u <=9 or liter u) then
897   << fancy!-prin2!*(u,t);
898      return if overflowed!* then fancy!-fail(pos,tpos,fl);
899   >>;
900   fancy!-prin2!*("{",0);
901   w := fancy!-maprint(u,p);
902   fancy!-prin2!*("}",0);
903   if w='failed then return fancy!-fail(pos,tpos,fl);
904  end;
905
906symbolic procedure fancy!-fail(pos,tpos,fl);
907 <<
908     overflowed!* := nil;
909     fancy!-pos!* := pos;
910     fancy!-texpos := tpos;
911     fancy!-line!* := fl;
912     'failed
913 >>;
914
915put('quotient,'fancy!-prifn,'fancy!-quotpri);
916
917symbolic procedure fancy!-prinfit(u, p, op);
918% Display u (as with maprint) with op in front of it, but starting
919% a new line before it if there would be overflow otherwise.
920   begin scalar pos,tpos,fl,w,ll,f;
921     if pairp u and (f:=get(car u,'fancy!-prinfit)) then
922        return apply(f,{u,p,op});
923     pos:=fancy!-pos!*;
924     tpos:=fancy!-texpos;
925     fl:=fancy!-line!*;
926     begin scalar testing!-width!*;
927       testing!-width!*:=t;
928       if op then w:=fancy!-oprin op;
929       if w neq 'failed then w := fancy!-maprint(u,p);
930     end;
931     if w neq 'failed then return t;
932     fancy!-line!*:=fl; fancy!-pos!*:=pos; fancy!-texpos:=tpos;
933     if testing!-width!* and w eq 'failed then return w;
934
935     if op='plus and eqcar(u,'minus) then <<op := 'minus; u:=cadr u>>;
936     w:=if op then fancy!-oprin op;
937       % if the operator causes the overflow, we break the line now.
938     if w eq 'failed then
939     <<fancy!-terpri!* nil;
940       if op then fancy!-oprin op;
941       return fancy!-maprint(u, p);>>;
942       % if at least half the line is still free and the
943       % object causing the overflow has been a number,
944       % let it break.
945     if fancy!-pos!* < (ll:=linelength(nil)) then
946             if numberp u then return fancy!-prin2number u else
947         if eqcar(u,'!:rd!:) then return fancy!-rdprin u;
948       % generate a line break if we are not just behind an
949       % opening bracket at the beginning of a line.
950     if fancy!-pos!* > linelength nil / 2 or
951          not eqcar(fancy!-last!-symbol(),'bkt) then
952           fancy!-terpri!* nil;
953     return fancy!-maprint(u, p);
954   end;
955
956%-----------------------------------------------------------
957%
958%   support for print format property
959%
960%-----------------------------------------------------------
961
962symbolic procedure print_format(f,pat);
963  % Assign a print pattern p to the operator form f.
964put(car f, 'print!-format, (cdr f . pat) . get(car f, 'print!-format));
965
966symbolic operator print_format;
967
968symbolic procedure fancy!-print!-format(u,p);
969 fancy!-level
970  begin scalar fmt,fmtl,a;
971   fmtl:=get(car u,'print!-format);
972 l:
973   if null fmtl then return 'failed;
974   fmt := car fmtl; fmtl := cdr fmtl;
975   if length(car fmt) neq length cdr u then goto l;
976   a:=pair(car fmt,cdr u);
977   return fancy!-print!-format1(cdr fmt,p,a);
978  end;
979
980symbolic procedure fancy!-print!-format1(u,p,a);
981  begin scalar w,x,pl,bkt,obkt,q;
982   if eqcar(u,'list) then u:= cdr u;
983   while u and w neq 'failed do
984   <<x:=car u; u:=cdr u;
985     if eqcar(x,'list) then x:=cdr x;
986     obkt := bkt; bkt:=nil;
987     if obkt then fancy!-prin2!*('!{,0);
988     w:=if pairp x then fancy!-print!-format1(x,p,a) else
989        if memq(x,'(!( !) !, !. !|)) then
990         <<if x eq '!( then <<pl:=p.pl; p:=0>> else
991           if x eq '!) then <<p:=car pl; pl:=cdr pl>>;
992           fancy!-prin2!*(x,1)>> else
993        if x eq '!_ or x eq '!^ then <<bkt:=t;fancy!-prin2!*(x,0)>> else
994        if q:=assoc(x,a) then fancy!-maprint(cdr q,p) else
995        fancy!-maprint(x,p);
996     if obkt then fancy!-prin2!*('!},0);
997    >>;
998    return w;
999  end;
1000
1001
1002%-----------------------------------------------------------
1003%
1004%   some operator specific print functions
1005%
1006%-----------------------------------------------------------
1007
1008symbolic procedure fancy!-prefix!-operator(u);
1009 % Print as function, but with a special character.
1010   begin scalar sy;
1011     sy :=
1012       get(u,'fancy!-functionsymbol) or get(u,'fancy!-special!-symbol);
1013     if sy
1014      then fancy!-special!-symbol(sy,get(u,'fancy!-symbol!-length) or 2)
1015      else fancy!-prin2!*(u,t);
1016   end;
1017
1018put('sqrt,'fancy!-prifn,'fancy!-sqrtpri);
1019
1020symbolic procedure fancy!-sqrtpri(u);
1021    fancy!-sqrtpri!*(cadr u,2);
1022
1023symbolic procedure fancy!-sqrtpri!*(u,n);
1024  fancy!-level
1025   begin
1026     if not numberp n and not liter n then return 'failed;
1027     fancy!-prin2!*("\sqrt",0);
1028     if n neq 2 then
1029     <<fancy!-prin2!*("[",0);
1030       fancy!-prin2!*("\,",1);
1031       fancy!-prin2!*(n,t);
1032       fancy!-prin2!*("]",0);
1033     >>;
1034     return fancy!-maprint!-tex!-bkt(u,0,t);
1035   end;
1036
1037
1038symbolic procedure fancy!-sub(l,p);
1039% Prints expression in an exponent notation.
1040  if get('expt,'infix)<=p then
1041      fancy!-in!-brackets({'fancy!-sub,mkquote l,0},'!(,'!))
1042    else
1043   fancy!-level
1044    begin scalar eqs,w;
1045      l:=cdr l;
1046      while cdr l do <<eqs:=append(eqs,{car l}); l:=cdr l>>;
1047      l:=car l;
1048      testing!-width!* := t;
1049      w := fancy!-maprint(l,get('expt,'infix));
1050      if w='failed then return w;
1051      fancy!-prin2!*("\bigl",0);
1052      fancy!-prin2!*("|",1);
1053      fancy!-prin2!*('!_,0);
1054      fancy!-prin2!*("{",0);
1055      w:=fancy!-inprint('!*comma!*,0,eqs);
1056      fancy!-prin2!*("}",0);
1057      return w;
1058   end;
1059
1060put('sub,'fancy!-pprifn,'fancy!-sub);
1061
1062
1063put('factorial,'fancy!-pprifn,'fancy!-factorial);
1064
1065symbolic procedure fancy!-factorial(u,n);
1066  fancy!-level
1067   begin scalar w;
1068     w := (if atom cadr u then fancy!-maprint(cadr u,9999)
1069              else
1070           fancy!-in!-brackets({'fancy!-maprint,mkquote cadr u,0},
1071                               '!(,'!))
1072          );
1073     fancy!-prin2!*("!",2);
1074     return w;
1075   end;
1076
1077put('binomial,'fancy!-prifn,'fancy!-binomial);
1078
1079symbolic procedure fancy!-binomial u;
1080  fancy!-level
1081   begin scalar w1,w2,!*list;
1082     fancy!-prin2!*("\left(\begin{array}{c}",2);
1083     w1 := fancy!-maprint(cadr u,0);
1084     fancy!-prin2!*("\\",0);
1085     w2 := fancy!-maprint(caddr u,0);
1086     fancy!-prin2!*("\end{array}\right)",2);
1087     if w1='failed or w2='failed then return 'failed;
1088   end;
1089
1090symbolic procedure fancy!-intpri(u,p);
1091% Fancy integral print.
1092  if p>get('times,'infix) then
1093    fancy!-in!-brackets({'fancy!-intpri,mkquote u,0},'!(,'!))
1094   else
1095  fancy!-level
1096  begin scalar w1,w2,lo,hi,var;
1097     var := caddr u;
1098     if cdddr u then lo:=cadddr u;
1099     if lo and cddddr u then hi := car cddddr u;
1100     if fancy!-height(cadr u,1.0) > 3 then
1101         fancy!-prin2!*("\Int ",0)
1102       else
1103         fancy!-prin2!*("\int ",0);
1104     if lo then  << fancy!-prin2!*('!_,0);
1105                  fancy!-maprint!-tex!-bkt(lo,0,t) where !*list=nil;
1106                 >>;
1107     if hi then << fancy!-prin2!*('!^,0);
1108                  fancy!-maprint!-tex!-bkt(hi,0,t) where !*list=nil;
1109                 >>;
1110     w1:=fancy!-maprint(cadr u,0);
1111     fancy!-prin2!*("\,d\,",2);
1112     w2:=fancy!-maprint(caddr u,0);
1113     if w1='failed or w2='failed then return 'failed;
1114   end;
1115
1116symbolic procedure fancy!-height(u,h);
1117  % Fancy height. Estimate the height of an expression, this is a
1118  % subroutine of fancy!-intpri.
1119    if atom u then h
1120    else if car u = 'minus then fancy!-height(cadr u,h)
1121    else if car u = 'plus or car u = 'times then
1122      eval('max. for each w in cdr u collect fancy!-height(w,h))
1123    else if car u = 'expt then
1124         fancy!-height(cadr u,h) + fancy!-height(caddr u,h*0.8)
1125    else if car u = 'quotient then
1126         fancy!-height(cadr u,h) + fancy!-height(caddr u,h)
1127    else if get(car u,'simpfn) then fancy!-height(cadr u,h)
1128    else h;
1129
1130put('int,'fancy!-pprifn,'fancy!-intpri);
1131
1132symbolic procedure fancy!-sumpri!*(u,p,mode);
1133  if p>get('minus,'infix) then
1134    fancy!-in!-brackets({'fancy!-sumpri!*,mkquote u,0,mkquote mode},
1135                         '!(,'!))
1136   else
1137  fancy!-level
1138   begin scalar w,w0,w1,lo,hi,var;
1139     var := caddr u;
1140     if cdddr u then lo:=cadddr u;
1141     if lo and cddddr u then hi := car cddddr u;
1142     w:=if lo then {'equal,var,lo} else var;
1143     if mode = 'sum then
1144        fancy!-prin2!*("\sum",0) % big SIGMA
1145     else if mode = 'prod then
1146        fancy!-prin2!*("\prod",0); % big PI
1147     fancy!-prin2!*('!_,0);
1148     fancy!-prin2!*('!{,0);
1149     if w then w0:=fancy!-maprint(w,0) where !*list=nil;
1150     fancy!-prin2!*('!},0);
1151     if hi then <<fancy!-prin2!*('!^,0);
1152                  fancy!-maprint!-tex!-bkt(hi,0,nil) where !*list=nil;
1153                 >>;
1154     fancy!-prin2!*('!\!, ,1);
1155     w1:=fancy!-maprint(cadr u,0);
1156     if w0='failed or w1='failed then return 'failed;
1157   end;
1158
1159symbolic procedure fancy!-sumpri(u,p); fancy!-sumpri!*(u,p,'sum);
1160
1161put('sum,'fancy!-pprifn,'fancy!-sumpri);
1162put('infsum,'fancy!-pprifn,'fancy!-sumpri);
1163
1164symbolic procedure fancy!-prodpri(u,p); fancy!-sumpri!*(u,p,'prod);
1165
1166put('prod,'fancy!-pprifn,'fancy!-prodpri);
1167
1168symbolic procedure fancy!-limpri(u,p);
1169  if p>get('minus,'infix) then
1170    fancy!-in!-brackets({'fancy!-limpri,mkquote u,0},'!(,'!))
1171   else
1172  fancy!-level
1173   begin scalar w,lo,var;
1174     var := caddr u;
1175     if cdddr u then lo:=cadddr u;
1176     fancy!-prin2!*("\lim",6);
1177     fancy!-prin2!*('!_,0);
1178     fancy!-prin2!*('!{,0);
1179     fancy!-maprint(var,0);
1180     fancy!-prin2!*("\to",0);
1181     fancy!-prin2!*('! ,0); % make sure there is space before the following symbol
1182     fancy!-maprint(lo,0) where !*list=nil;
1183     fancy!-prin2!*('!},0);
1184     w:=fancy!-maprint(cadr u,0);
1185     return w;
1186   end;
1187
1188put('limit,'fancy!-pprifn,'fancy!-limpri);
1189
1190symbolic procedure fancy!-listpri(u);
1191 fancy!-level
1192 (if null cdr u then fancy!-maprint('empty!-set,0)
1193   else
1194  fancy!-in!-brackets(
1195   {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote cdr u},
1196               '!{,'!})
1197  );
1198
1199put('list,'fancy!-prifn,'fancy!-listpri);
1200put('list,'fancy!-flatprifn,'fancy!-listpri);
1201
1202put('!*sq,'fancy!-reform,'fancy!-sqreform);
1203
1204symbolic procedure fancy!-sqreform u;
1205   << u := cadr u;
1206      if !*pri or wtl!* then prepreform prepsq!* sqhorner!* u
1207       else if denr u = 1 then fancy!-sfreform numr u
1208       else {'quotient,fancy!-sfreform numr u,fancy!-sfreform denr u} >>;
1209
1210symbolic procedure fancy!-sfreform u;
1211    begin scalar z;
1212      while not domainp u do <<z := fancy!-termreform lt u . z; u := red u >>;
1213      if not null u then z := prepd u . z;
1214      return replus reversip z;
1215   end;
1216
1217
1218symbolic procedure fancy!-termreform u;
1219     begin scalar v,w,z,sgn;
1220	v := tc u;
1221      	u := tpow u;
1222      	if (w := kernlp v) and not !:onep w
1223        then <<v := quotf(v,w);
1224               if minusf w then <<sgn := t; w := !:minus w>>>>;
1225      if w and not !:onep w
1226        then z := (if domainp w then prepd w else w) . z;
1227      z := fancy!-powerreform u . z;
1228      if not(domainp v and !:onep v) then z := fancy!-sfreform v . z;
1229      z := retimes reversip z;
1230      if sgn then z := {'minus,z};
1231      return z;
1232     end;
1233
1234symbolic procedure fancy!-powerreform u;
1235   begin scalar b;
1236      % Process main variable.
1237      if atom car u then b := car u
1238       else if not atom caar u then b := fancy!-sfreform car u
1239       else if caar u eq '!*sq then b := fancy!-sqreform cadar u
1240       else b := car u;
1241      % Process degree.
1242      if (u := pdeg u)=1 then return b
1243      else return {'expt,b,u}
1244   end;
1245
1246put('df,'fancy!-pprifn,'fancy!-dfpri);
1247
1248% 9-Dec-93: 'total repaired
1249
1250symbolic procedure fancy!-dfpri(u,l);
1251  (if flagp(cadr u,'print!-indexed) or
1252      pairp cadr u and flagp(caadr u,'print!-indexed)
1253    then fancy!-dfpriindexed(u,l)
1254   else if m = 'partial then fancy!-dfpri0(u,l,'partial!-df)
1255   else if m = 'total then fancy!-dfpri0(u,l,'!d)
1256   else if m = 'indexed then fancy!-dfpriindexed(u,l)
1257   else rederr "unknown print mode for DF")
1258        where m=fancy!-mode('fancy_print_df);
1259
1260symbolic procedure fancy!-partialdfpri(u,l);
1261     fancy!-dfpri0(u,l,'partial!-df);
1262
1263symbolic procedure fancy!-dfpri0(u,l,symb);
1264 if null cddr u then fancy!-maprin0{'times,symb,cadr u} else
1265 if l >= get('expt,'infix) then % brackets if exponented
1266  fancy!-in!-brackets({'fancy!-dfpri0,mkquote u,0,mkquote symb},
1267                      '!(,'!))
1268   else
1269 fancy!-level
1270  begin scalar x,d,q; integer n,m;
1271    u:=cdr u;
1272    q:=car u;
1273    u:=cdr u;
1274    while u do
1275    <<x:=car u; u:=cdr u;
1276      if u and numberp car u then
1277      <<m:=car u; u := cdr u>> else m:=1;
1278      n:=n+m;
1279      d:= append(d,{symb,if m=1 then x else {'expt,x,m}});
1280    >>;
1281    return fancy!-maprin0
1282    {'quotient, {'times,if n=1 then symb else
1283                                    {'expt,symb,n},q},
1284       'times. d};
1285  end;
1286
1287symbolic procedure fancy!-dfpriindexed(u,l);
1288   if null cddr u then fancy!-maprin0{'times,'partial!-df,cadr u} else
1289   begin scalar w;
1290      w:=fancy!-maprin0 cadr u;
1291      if testing!-width!* and w='failed then return w;
1292      w :=fancy!-print!-indexlist fancy!-dfpriindexedx(cddr u,nil);
1293      return w;
1294   end;
1295
1296symbolic procedure fancy!-dfpriindexedx(u,p);
1297  if null u then nil else
1298  if numberp car u then
1299   append(for i:=2:car u collect p,fancy!-dfpriindexedx(cdr u,p))
1300     else
1301  car u . fancy!-dfpriindexedx(cdr u,car u);
1302
1303put('!:rd!:,'fancy!-prifn,'fancy!-rdprin);
1304put('!:rd!:,'fancy!-flatprifn,'fancy!-rdprin);
1305
1306symbolic procedure fancy!-rdprin u;
1307 fancy!-level
1308  begin scalar digits; integer dotpos,xp;
1309   u:=rd!:explode u;
1310   digits := car u; xp := cadr u; dotpos := caddr u;
1311   return fancy!-rdprin1(digits,xp,dotpos);
1312  end;
1313
1314symbolic procedure fancy!-rdprin1(digits,xp,dotpos);
1315  begin scalar str;
1316   if xp>0 and dotpos+xp<length digits-1 then
1317      <<dotpos := dotpos+xp; xp:=0>>;
1318    % build character string from number.
1319   for i:=1:dotpos do
1320   <<str := car digits . str;
1321     digits := cdr digits; if null digits then digits:='(!0);
1322   >>;
1323   str := '!. . str;
1324   for each c in digits do str :=c.str;
1325   if not(xp=0) then
1326   <<str:='!e.str;
1327     for each c in explode2 xp do str:=c.str>>;
1328   if testing!-width!* and
1329      fancy!-pos!* + 2*length str > 2 * linelength nil then
1330        return 'failed;
1331   fancy!-prin2number1 reversip str;
1332  end;
1333
1334put('!:cr!:,'fancy!-pprifn,'fancy!-cmpxprin);
1335put('!:cr!:,'fancy!-pprifn,'fancy!-cmpxprin);
1336
1337symbolic procedure fancy!-cmpxprin(u,l);
1338   begin scalar rp,ip;
1339     rp:=reval {'repart,u}; ip:=reval {'impart,u};
1340     return fancy!-maprint(
1341       if ip=0 then rp else
1342       if rp=0 then {'times,ip,'!i} else
1343        {'plus,rp,{'times,ip,'!i}},l);
1344   end;
1345
1346symbolic procedure fancy!-dn!:prin u;
1347 begin scalar lst; integer dotpos,ex;
1348  lst := bfexplode0x (cadr u, cddr u);
1349  ex := cadr lst;
1350  dotpos := caddr lst;
1351  lst := car lst;
1352  return fancy!-rdprin1 (lst,ex,dotpos)
1353 end;
1354
1355put ('!:dn!:, 'fancy!-prifn, 'fancy!-dn!:prin);
1356
1357fmp!-switch t;
1358
1359endmodule;
1360
1361
1362%-------------------------------------------------------
1363
1364module f;   % Matrix printing routines.
1365
1366
1367fluid '(!*nat);
1368
1369fluid '(obrkp!*);
1370
1371symbolic procedure fancy!-setmatpri(u,v);
1372   fancy!-matpri1(cdr v,u);
1373
1374put('mat,'fancy!-setprifn,'fancy!-setmatpri);
1375
1376symbolic procedure fancy!-matpri u;
1377   fancy!-matpri1(cdr u,nil);
1378
1379
1380put('mat,'fancy!-prifn,'fancy!-matpri);
1381
1382symbolic procedure fancy!-matpri1(u,x);
1383   % Prints a matrix canonical form U with name X.
1384   % Tries to do fancy display if nat flag is on.
1385  begin scalar w;
1386     w := fancy!-matpri2(u,x,nil);
1387     if w neq 'failed or testing!-width!* then return w;
1388     fancy!-matpri3(u,x);
1389  end;
1390
1391symbolic procedure fancy!-matpri2(u,x,bkt);
1392  % Tries to print matrix as compact block.
1393  fancy!-level
1394    begin scalar w,testing!-width!*,fl,fp,fmat,row,elt,fail;
1395      integer cols,rows,rw,maxpos;
1396      testing!-width!*:=t;
1397      rows := length u;
1398      cols := length car u;
1399      if cols*rows>400 then return 'failed;
1400
1401      if x then
1402      << fancy!-maprint(x,0); fancy!-prin2!*(":=",4) >>;
1403      fl := fancy!-line!*; fp := fancy!-pos!*;
1404         %  remaining room for the columns.
1405      rw := linelength(nil)-2 -(fancy!-pos!*+2);
1406      rw := rw/cols;
1407      fmat := for each row in u collect
1408        for each elt in row collect
1409          if not fail then
1410          <<fancy!-line!*:=nil; fancy!-pos!*:=0;
1411            w:=fancy!-maprint(elt,0);
1412            if fancy!-pos!*>maxpos then maxpos:=fancy!-pos!*;
1413            if w='failed or fancy!-pos!*>rw
1414              then fail:=t else
1415               (fancy!-line!*.fancy!-pos!*)
1416          >>;
1417     if fail then return 'failed;
1418     testing!-width!* := nil;
1419       % restore output line.
1420     fancy!-pos!* := fp; fancy!-line!* := fl;
1421       % TEX header
1422     fancy!-prin2!*(bldmsg("\left%w\begin{array}{",
1423                        if bkt then car bkt else "("),0);
1424     for i:=1:cols do fancy!-prin2!*("c",0);
1425     fancy!-prin2!*("}",0);
1426       % join elements.
1427     while fmat do
1428     <<row := car fmat; fmat:=cdr fmat;
1429       while row do
1430       <<elt:=car row; row:=cdr row;
1431         fancy!-line!* := append(car elt,fancy!-line!*);
1432         if row then fancy!-line!* :='!& . fancy!-line!*
1433          else if fmat then
1434             fancy!-line!* := "\\". fancy!-line!*;
1435       >>;
1436     >>;
1437     fancy!-prin2!*(bldmsg("\end{array}\right%w",
1438                        if bkt then cdr bkt else ")"),0);
1439      % compute total horizontal extent of matrix
1440     fancy!-pos!* := fp + maxpos*(cols+1);
1441    return t;
1442    end;
1443
1444
1445symbolic procedure fancy!-matpri3(u,x);
1446  if null x then fancy!-matpriflat('mat.u) else
1447   begin scalar obrkp!*,!*list;
1448      integer r,c;
1449      obrkp!* := nil;
1450      if null x then x:='mat;
1451      fancy!-terpri!*;
1452      for each row in u do
1453      <<r:=r+1; c:=0;
1454        for each elt in row do
1455        << c:=c+1;
1456           if not !*nero then
1457           << fancy!-prin2!*(x,t);
1458              fancy!-print!-indexlist {r,c};
1459              fancy!-prin2!*(":=",t);
1460              fancy!-maprint(elt,0);
1461              fancy!-terpri!* t;
1462           >>;
1463        >>;
1464      >>;
1465   end;
1466
1467symbolic procedure fancy!-matpriflat(u);
1468 begin
1469  fancy!-oprin 'mat;
1470  fancy!-in!-brackets(
1471   {'fancy!-matpriflat1,mkquote '!*wcomma!*,0,mkquote cdr u},
1472               '!(,'!));
1473 end;
1474
1475symbolic procedure fancy!-matpriflat1(op,p,l);
1476   % inside algebraic list
1477 begin scalar fst,w;
1478   for each v in l do
1479     <<if fst then
1480       << fancy!-prin2!*("\,",1);
1481          fancy!-oprin op;
1482          fancy!-prin2!*("\,",1);
1483       >>;
1484  % if the next row does not fit on the current print line
1485  % we move it completely to a new line.
1486       if fst then
1487        w:= fancy!-level
1488         fancy!-in!-brackets(
1489          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
1490            '!(,'!)) where testing!-width!*=t;
1491       if w eq 'failed then fancy!-terpri!* t;
1492       if not fst or w eq 'failed then
1493         fancy!-in!-brackets(
1494          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
1495            '!(,'!));
1496       fst := t;
1497     >>;
1498  end;
1499
1500put('mat,'fancy!-flatprifn,'fancy!-matpriflat);
1501
1502symbolic procedure fancy!-matfit(u,p,op);
1503% Prinfit routine for matrix.
1504% a new line before it if there would be overflow otherwise.
1505 fancy!-level
1506   begin scalar pos,tpos,fl,fp,w,ll;
1507     pos:=fancy!-pos!*;
1508     tpos:=fancy!-texpos;
1509     fl:=fancy!-line!*;
1510     begin scalar testing!-width!*;
1511       testing!-width!*:=t;
1512       if op then w:=fancy!-oprin op;
1513       if w neq 'failed then w := fancy!-matpri(u);
1514     end;
1515     if w neq 'failed or
1516       (w eq 'failed and testing!-width!*) then return w;
1517     fancy!-line!*:=fl; fancy!-pos!*:=pos; fancy!-texpos:=tpos; w:=nil;
1518     fp := fancy!-page!*;
1519% matrix: give us a second chance with a fresh line
1520     begin scalar testing!-width!*;
1521       testing!-width!*:=t;
1522       if op then w:=fancy!-oprin op;
1523       fancy!-terpri!* nil;
1524       if w neq 'failed then w := fancy!-matpri u;
1525     end;
1526     if w neq 'failed then return t;
1527     fancy!-line!*:=fl; fancy!-pos!*:=pos; fancy!-texpos:=tpos; fancy!-page!*:=fp;
1528
1529     ll:=linelength nil;
1530     if op then fancy!-oprin op;
1531     if atom u or fancy!-pos!* > ll / 2 then fancy!-terpri!* nil;
1532     return fancy!-matpriflat(u);
1533   end;
1534
1535put('mat,'fancy!-prinfit,'fancy!-matfit);
1536
1537put('taylor!*,'fancy!-reform,'taylor!*print1);
1538
1539endmodule;
1540
1541module fancy_specfn;
1542
1543put('Euler_gamma,'fancy!-special!-symbol,"\gamma");
1544
1545put('BesselI,'fancy!-prifn,'fancy!-bessel);
1546put('BesselJ,'fancy!-prifn,'fancy!-bessel);
1547put('BesselY,'fancy!-prifn,'fancy!-bessel);
1548put('BesselK,'fancy!-prifn,'fancy!-bessel);
1549put('BesselI,'fancy!-functionsymbol,'(ascii 73));
1550put('BesselJ,'fancy!-functionsymbol,'(ascii 74));
1551put('BesselY,'fancy!-functionsymbol,'(ascii 89));
1552put('BesselK,'fancy!-functionsymbol,'(ascii 75));
1553
1554symbolic procedure fancy!-bessel(u);
1555 fancy!-level
1556  begin scalar w;
1557   fancy!-prefix!-operator car u;
1558   w:=fancy!-print!-one!-index cadr u;
1559   if testing!-width!* and w eq 'failed then return w;
1560   return fancy!-print!-function!-arguments cddr u;
1561  end;
1562
1563put('polylog,'fancy!-prifn,'fancy!-bessel);
1564put('polylog,'fancy!-functionsymbol,'!L!i);
1565
1566put('ChebyshevU,'fancy!-prifn,'fancy!-bessel);
1567put('ChebyshevT,'fancy!-prifn,'fancy!-bessel);
1568put('ChebyshevU,'fancy!-functionsymbol,'(ascii 85));
1569put('ChebyshevT,'fancy!-functionsymbol,'(ascii 84));
1570
1571% Hypergeometric functions.
1572
1573put('empty!*,'fancy!-special!-symbol,32);
1574
1575symbolic procedure fancy!-hypergeometric u;
1576 fancy!-level
1577  begin scalar w,a1,a2,a3;
1578   a1 :=cdr cadr u;
1579   a2 := cdr caddr u;
1580   a3 := cadddr u;
1581   fancy!-special!-symbol(get('empty!*,'fancy!-special!-symbol),nil);
1582   w:=fancy!-print!-one!-index length a1;
1583   if testing!-width!* and w eq 'failed then return w;
1584   fancy!-prin2!*("F",nil);
1585   w:=fancy!-print!-one!-index length a2;
1586   if testing!-width!* and w eq 'failed then return w;
1587   fancy!-prin2!*("(",nil);
1588   if null a1 then a1 := list '!-;
1589   if null a2 then a2 := list '!-;
1590   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
1591   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
1592   fancy!-prin2!*("\,",1);
1593   w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
1594   fancy!-prin2!*("\,",1);
1595   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
1596   fancy!-prin2!*(")",nil);
1597   return w;
1598  end;
1599
1600put('hypergeometric,'fancy!-prifn,'fancy!-hypergeometric);
1601
1602% hypergeometric({1,2,u/w,v},{5,6},sqrt x);
1603
1604symbolic procedure fancy!-meijerg u;
1605 fancy!-level
1606  begin scalar w,a1,a2,a3;
1607   integer n,m,p,q;
1608   a1 :=cdr cadr u;
1609   a2 := cdr caddr u;
1610   a3 := cadddr u;
1611   m:=length cdar a2;
1612   n:=length cdar a1;
1613   a1 := append(cdar a1 , cdr a1);
1614   a2 := append(cdar a2 , cdr a2);
1615   p:=length a1; q:=length a2;
1616   fancy!-prin2!*("G",nil);
1617   w := w eq 'failed or
1618        fancy!-print!-indexlist1({m,n},'!^,nil);
1619   w := w eq 'failed or
1620        fancy!-print!-indexlist1({p,q},'!_,nil);
1621   fancy!-prin2!*("(",nil);
1622   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
1623   w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
1624   if null a1 then a1 := list '!-;
1625   if null a2 then a2 := list '!-;
1626   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
1627   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
1628   fancy!-prin2!*(")",nil);
1629   return w;
1630  end;
1631
1632put('MeijerG,'fancy!-prifn,'fancy!-meijerg);
1633
1634% meijerg({{},1},{{0}},x);
1635
1636endmodule;
1637
1638end;
1639