fmprint.red 46 KB

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