1% mathtex.red                     Rainer Schoepf and Arthur Norman 2015
2
3
4% The aim in due course is to convert algebraic expressions into
5% a layout that would be a reasonable approximation to the one that
6% TeX would have used. This builds on the code in boxdisplay.red that
7% Rainer had written, but will now take a much more agressive line in
8% positioning characters based on metrics from the STIX family of
9% Unicode fonts.
10
11symbolic$
12
13%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
14
15% During initial development I wan to be able to test by loading just
16% this file into Reduce. So I will cause that to read in the other
17% things I need... In the fullness of time and if things end up working
18% well a tidier build scheme will be established.
19
20on comp, backtrace;
21
22in "charmetrics.red"$
23in "uninames.red"$
24
25
26#if (memq 'psl lispsystem!*)
27
28% This will only be used on numbers here, so issues of Unicode do
29% not intrude. It takes an input and returns a list of codepoints.
30
31symbolic procedure explodecn u;
32  for each x in explode2 u collect car id2list x;
33
34#endif
35
36%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
37
38
39
40% Question: With this many components should a Display_Box be
41% converted to be represented as a vector or a tree-like structure
42% rather than a rather long list? Well that is just a performance not
43% a functionality issue so not to be fussed about just now!
44
45symbolic inline procedure
46  MakeDisplayBox(h,d,w,exp,op,args,parens!?,p,enc);
47    list('Display_Box,h,d,w,exp,op,args,parens!?,p,enc)$
48
49% The "accessors" statement defines the names functions to access
50% parts of the data structure. It also defines functions with name such
51% as set_BoxHeight for updating the structure, and arranges that Reduce
52% can recognize the selectors on the left hand side of an assigment
53% statement so that e.g.
54%    BoxHeight b := ...
55% becomes valid.
56
57accessors (!_ . (BoxHeight . (BoxDepth . (BoxWidth . (BoxExpression .
58                (BoxOperator . (BoxArgList . (BoxIsParenthesized .
59                (BoxPenalty . (BoxEnclosingBox . !_))))))))))$
60
61symbolic inline procedure CopyDisplayBox b;
62  append(b,nil)$
63
64symbolic inline procedure BoxIsNonBreakable box;
65  null BoxPenalty box$
66
67symbolic inline procedure IsAatomDisplayBox box;
68  atom BoxExpression box$
69
70% The current plan is that all measurements built into boxes here will be
71% in units of 1/1000th of a point or possibly pixel. The metric information
72% I have about fonts is based on a 1000-unit high character cell. I will scale
73% these measurements by the font size in points. Now a quick sketch of the
74% balance between accuracy and overflow. An A4 page at a resolution of 1200
75% dpi has around 13 million pixels from top to bottom and that fits within
76% 24-bits (ie comfortably within a CSL fixnum, and even more comfortably
77% within a C 32-bit word). The smallest point size I think it could make sense
78% to display would be 5pt, and at that the x height would end up at around
79% 2500 units - on a reasonable screen it is more likely that characters will
80% end up around 10000 units tall. I think that that means that rounding errors
81% due to fixed point measurements will not be important at all. In particular
82% rounding and conversion at the point of final rendering will be a much
83% greater risk - especially on-screen but even when displaying on high
84% resolution printers with characters ending up up to an inch tall.
85
86
87symbolic inline procedure ParenHeight(h,d);
88  max(h,d+1)$
89
90symbolic inline procedure ParenDepth(h,d);
91  max(h-1,d)$
92
93symbolic inline procedure ParenWidth(h,d);
94  if h > 1 or d > 0 then 2 else 1$
95
96symbolic procedure BuildDisplayBox (exp,parens!?);
97  if atom exp then BuildAtomDisplayBox exp
98   else begin scalar op,opp;
99     op := car exp;
100     opp := get(op,'BuildDisplayBox);
101     return if not null opp then apply3(opp,op,exp,parens!?)
102             else if not null get(op,'infix)
103              then BuildInfixDisplayBox(op,exp,parens!?)
104             else BuildOpDisplayBox(op,exp,parens!?);
105   end$
106
107% Here I will measure and format a string of characters. This has
108% to be done relative to a given font and size. I will specify the font
109% as one of the codes as in charmetrics.red, so e.g.
110%    CurrentFont := get('SizeOneSym, 'font_number);
111% while the size will be an integer representing the actual font
112% size to be used. I will put these in the range 16-52, with an attempt
113% to get the size ratios between them abough right. My idea here is that
114% if I ask for fonts at an integer point size then the renderer may get on
115% better than if I ask for fractional sizes, and the choices here are
116% rather broadly correct (in pixels) for a display on a high definition
117% screen...  However these can then be adjusted later by somebody who has
118% proper sensitivity to appearance.
119%
120%    tiny          17
121%    scriptsize    18
122%    footnotesize  20
123%    small         22
124%    normalsize    24
125%    large         26
126%    Large         28
127%    LARGE         34
128%    huge          40
129%    Huge          50
130
131fluid '(CurrentFont CurrentSize !*ligatures);
132
133CurrentFont := get('General, 'font_number);
134CurrentSize := 24;
135% I can enable or disable use of ligatures...
136!*ligatures := t;
137
138% This returns a list of x-offsets and codepoints, and also leave
139% c_width, c_llx etc set with information about a bounding box for the
140% text. Again remember that all this is done in internal units that would
141% make a 1-point character fit in a box of height 1000.
142% This uses the escapement and kern info for characters within the name
143% but positions the material so that its bounding box starts at x=0 and so
144% the proper output information is c_llx, c_lly, c_urx and c_ury, with
145% c_width not useful. Furthermore c_llx should always be zero.
146
147symbolic procedure MeasureAtom a;
148  begin
149    scalar c, w, r, first, height, depth, left, right;
150% The next line takes a symbol and delivers a list of the Unicode
151% characters that make it up. So for instance
152%      wideid2list '!#alpha;!#omega;;     => (945 969)
153% (note that the symbol there contains two Greek letters).
154% This funution can be given a symbol or a string or a number.
155    if numberp a then first := explodecn a
156    else if stringp a then first := widestring2list a
157    else first := wideid2list a;
158    prin2 "TRACE: "; print first;
159    if !*ligatures then <<
160% Now I will deal with any ligatures
161      if null first then c := nil
162      else while first do <<
163        c := car first . c;
164        first := cdr first;
165        while first and
166              lookupchar(CurrentFont, car c) and
167              (w := lookupligature car first) do <<
168          c := w . cdr c;
169          first := cdr first >> >>;
170      c := reversip c;
171      prin2 "TRACE (after ligature expansion): "; print c >>
172    else c := first;
173    w := nil;
174    first := t;
175    for each x in c do <<
176% If I am on the second or subsequent character of a word then I check to
177% see if it kerns with this character, and adjust my running width (w)
178% accordingly.
179      if not first then w := w + lookupkernadjustment x;
180% Now look up the width of the current character (and in the process leave
181% behind information that can be used for kerning the one that will come
182% after it. I will make it an ERROR to try to use a character not supported
183% in the font that is being used.
184      if not lookupchar(CurrentFont, x) then
185        error(0, "Character not available in font");
186      if first then <<
187        w := -c_llx;
188        left := 0;
189        right := c_urx - c_llx;
190        height := c_ury;
191        depth := c_lly >>
192      else <<
193        right := w + c_urx;
194        height := max(height, c_ury);
195        depth := min(depth, c_llx) >>;
196      r := ((CurrentSize*w) . x) . r;% List of characters and their positions.
197      w := w + c_width;
198      first := nil >>;
199    c_llx := CurrentSize*left;
200    c_urx := CurrentSize*right;
201    c_lly := CurrentSize*depth;
202    c_ury := CurrentSize*height;
203    return reversip r
204  end;
205
206% The two test cases here should yield different spacings because of
207% kerning.  Specifically "VAR" should end up narrower than "VRA".
208
209MeasureAtom '!V!A!R;
210{c_llx, c_lly, c_urx, c_ury};
211MeasureAtom '!V!R!A;
212{c_llx, c_lly, c_urx, c_ury};
213
214
215
216
217symbolic procedure BuildAtomDisplayBox exp;
218  begin
219    scalar w;
220    w := MeasureAtom exp; % This depends on CurrentFont and CurrentSize
221% For typical characters both height and depth will be positive. I only
222% record the advance, not the left and right components of the bounding
223% box. That may be wrong, because for instance a character will in general
224% have nonzero left and right bearings. The data stored here will be
225% a list of pairs (offset . codepoint).
226    return MakeDisplayBox(c_height,-c_depth,c_width,w,nil,nil,nil,nil,nil)
227  end$
228
229symbolic inline procedure OpHeight op;
230  1$
231
232symbolic inline procedure OpDepth op;
233  0$
234
235symbolic inline procedure OpWidth op;
236  begin scalar prt;
237    prt := get(op,'prtch);
238    prt := if null prt then op else prt;
239    return if flagp(op,'spaced) then lengthc prt + 2
240            else lengthc prt
241  end$
242
243symbolic inline procedure HasPrecedenceOp(op1,op2);
244  get(op1,'infix) >= get(op2,'infix)$
245
246symbolic inline procedure HasPrecedenceExp(op,subexp);
247  if atom subexp or null get(op,'infix) then nil
248   else HasPrecedenceOp(op,car subexp)$
249
250symbolic procedure BuildOpDisplayBox(op,exp,parens!?);
251  begin scalar arglist,argl; integer h,d,w,pwidth,pos;
252    arglist := for each arg in cdr exp collect
253      BuildDisplayBox(arg,HasPrecedenceExp(op,arg));
254    h := OpHeight op; d := OpDepth op; w := OpWidth op;
255    for each arg in arglist do <<
256      if BoxHeight arg > h then h := BoxHeight arg;
257      if BoxDepth arg > d then d := BoxDepth arg >>;
258    if parens!? then <<
259      h := max(h,ParenHeight(h,d));
260      d := max(d,ParenDepth(h,d)) >>;
261    pwidth := ParenWidth(h,d);
262    pos := w + pwidth;
263    for each arg in arglist do <<
264      argl := list(pos,0,arg) . argl;
265      pos := pos + BoxWidth arg + 1 >>;
266    arglist := reversip argl;
267    w := pos - 1 + pwidth;
268    return MakeDisplayBox(h,d,w,exp,op,arglist,parens!?,0,nil)
269  end$
270
271symbolic procedure BuildInfixDisplayBox(op,exp,parens!?);
272  if null cddr exp then begin scalar x;
273     x := get(op,'unary);
274     if null x then return BuildOpDisplayBox(op,exp,parens!?)
275      else return BuildUnaryDisplayBox(x,exp,parens!?)
276    end
277   else BuildNaryDisplayBox(op,exp,parens!?)$
278
279
280symbolic procedure BuildNaryDisplayBox(op,exp,parens!?);
281  begin scalar arglist,argl; integer h,d,w,pos;
282    arglist := for each arg in cdr exp collect
283      BuildDisplayBox(arg,HasPrecedenceExp(op,arg));
284    h := OpHeight op; d := OpDepth op; w := OpWidth op;
285    for each arg in arglist do <<
286      if BoxHeight arg > h then h := BoxHeight arg;
287      if BoxDepth arg > d then d := BoxDepth arg >>;
288    if parens!? then <<
289      h := max(h,ParenHeight(h,d));
290      d := max(d,ParenDepth(h,d)) >>;
291    pos := if parens!? then ParenWidth(h,d) else 0;
292    argl := list list(pos,0,car arglist);
293    pos := pos + BoxWidth car arglist;
294    for each arg in cdr arglist do <<
295      if not (op eq get(BoxOperator arg,'alt)) then pos := pos + w;
296      argl := list(pos,0,arg) . argl;
297      pos := pos + BoxWidth arg >>;
298    if parens!? then pos := pos + ParenWidth(h,d);
299    return MakeDisplayBox(h,d,pos,exp,op,reversip argl,parens!?,0,nil)
300  end$
301
302
303symbolic procedure BuildUnaryDisplayBox(op,exp,parens!?);
304  begin scalar arg,argl; integer h,d,w,pos;
305    arg := cadr exp;
306    arg := BuildDisplayBox(arg,HasPrecedenceExp(op,arg));
307    h := OpHeight op; d := OpDepth op; w := OpWidth op;
308    if BoxHeight arg > h then h := BoxHeight arg;
309    if BoxDepth arg > d then d := BoxDepth arg;
310    if parens!? then <<
311      h := max(h,ParenHeight(h,d));
312      d := max(d,ParenDepth(h,d)) >>;
313    pos := if parens!? then w + ParenWidth(h,d) else w;
314    argl := list(list(pos,0,arg));
315    pos := pos + BoxWidth arg;
316    if parens!? then pos := pos + ParenWidth(h,d);
317    return MakeDisplayBox(h,d,pos,exp,op,argl,parens!?,0,nil)
318  end$
319
320
321symbolic procedure BuildExptDisplayBox(op,exp,parens!?);
322  begin scalar base,exponent; integer h,d,w,pos;
323    base := BuildDisplayBox(cadr exp,not atom cadr exp);
324    exponent := BuildDisplayBox(caddr exp,not atom caddr exp);
325    w := BoxWidth base + BoxWidth exponent;
326    d := BoxDepth base;
327    h := BoxHeight base + BoxDepth exponent + BoxHeight exponent;
328    if parens!? then <<
329      h := max(h,ParenHeight(h,d));
330      d := max(d,ParenDepth(h,d)) >>;
331    pos := if parens!? then ParenWidth(h,d) else 0;
332    return
333      MakeDisplayBox(h,d,w,exp,op,
334                     list(list(pos,0,base),
335                          list(pos + BoxWidth base,
336                               BoxHeight base + BoxDepth exponent,
337                               exponent)),
338                     parens!?,nil,nil)
339  end$
340
341put('expt,'BuildDisplayBox,'BuildExptDisplayBox)$
342
343symbolic procedure BuildQuotientDisplayBox(op,exp,parens!?);
344  begin scalar numer,denom; integer h,d,w,pos1,pos2;
345    numer := BuildDisplayBox(cadr exp,nil);
346    denom := BuildDisplayBox(caddr exp,nil);
347    w := max(BoxWidth numer,BoxWidth denom);
348    if w = BoxWidth numer then <<
349      pos1 := 1;
350      pos2 := 1 + (BoxWidth numer - BoxWidth denom) / 2 >>
351     else <<
352      pos1 := 1 + (BoxWidth denom - BoxWidth numer) / 2;
353      pos2 := 1 >>;
354    h := BoxHeight numer + BoxDepth numer + 1;
355    d := BoxHeight denom + BoxDepth denom;
356    if parens!? then <<
357      h := max(h,ParenHeight(h,d));
358      d := max(d,ParenDepth(h,d));
359      pos1 := pos1 + ParenWidth(h,d);
360      pos2 := pos2 + ParenWidth(h,d) >>;
361    return
362      MakeDisplayBox(h,d,w+2,exp,op,
363                     list(list(pos1,BoxDepth numer + 1,numer),
364                          list(pos2,-BoxHeight denom,denom)),
365                     parens!?,nil,nil)
366  end$
367
368put('quotient,'BuildDisplayBox,'BuildQuotientDisplayBox)$
369
370
371symbolic procedure BuildIntDisplayBox(op,exp,parens!?);
372  begin scalar integrand,var; integer h,d,w,pos;
373    integrand := BuildDisplayBox(cadr exp,nil);
374    var := BuildDisplayBox(caddr exp,nil);
375    h := max(BoxHeight integrand,BoxHeight var);
376    d := max(BoxDepth integrand,BoxDepth var);
377    h := max(h,d+1); %max(IntSignHeight(h,d),h);
378    d := h-1;        %max(IntSignDepth(h,d),d);
379    w := BoxWidth integrand + BoxWidth var + 5;
380    pos := BoxWidth integrand + 5;
381    if parens!? then <<
382      w := w + 2*ParenWidth(h,d);
383      pos := pos + ParenWidth(h,d) >>;
384    return
385      MakeDisplayBox(h,d,w,exp,op,
386                     list(list(ParenWidth(h,d) + 3,0,integrand),
387                          list(pos,0,var)),
388                     parens!?,nil,nil)
389  end$
390
391
392put('int,'BuildDisplayBox,'BuildIntDisplayBox)$
393
394
395symbolic procedure BreakDisplayBox(box,width_goal);
396  if BoxWidth box <= width_goal then nil . box
397   else if BoxIsNonBreakable box
398    then rederr("not implemented (breaking special display box)")
399% BreakSpecialDisplayBox(box,width_goal)
400   else begin scalar x,y,z; integer offset;
401     x := BoxArgList box;
402     if null cdr x then return
403       ((for each pos
404           in car BreakDisplayBox(caddr car x,width_goal - car car x)
405             collect (pos + car car x)) . box);
406    loop:
407     y := car x;
408     x := cdr x;
409     if null x then goto exitloop;
410     if car car x - offset > width_goal then <<
411       offset := car y;
412       z := car y . z;
413       if BoxWidth caddr y > width_goal then
414         for each pos in car BreakDisplayBox(caddr y,width_goal) do
415           z := (offset := (car y + pos)) . z >>;
416     goto loop;
417    exitloop:
418     if car y + BoxWidth caddr y - offset > width_goal
419       then if BoxWidth caddr y <= width_goal
420              then z := car y . z
421             else for each pos in
422                    car BreakDisplayBox(caddr y,width_goal) do
423                z := (offset := (car y + pos)) . z;
424     return reversip z . box
425   end$
426
427
428
429symbolic inline procedure IsSpecialDisplayBox box;
430  get(BoxOperator box,'InsertDisplayBox)$
431
432fluid '(!*DisplayArrayDepth!*)$
433
434symbolic inline procedure GetLine(disparray,n);
435  getv(disparray,n + !*DisplayArrayDepth!*)$
436
437symbolic procedure InsertLeftParen(disparray,x,y,h,d);
438  if h=1 and d=0 then PutChar(GetLine(disparray,y),x,'!()
439   else begin integer p;
440     p := ParenHeight(h,d) - 1;
441     for i := -p+1 : p-1 do PutChar(GetLine(disparray,y+i),x,'!|);
442     PutChar(GetLine(disparray,y+p),x,'!/);
443     PutChar(GetLine(disparray,y-p),x,'!\);
444   end$
445
446symbolic procedure InsertRightParen(disparray,x,y,h,d);
447  if h=1 and d=0 then PutChar(GetLine(disparray,y),x,'!))
448   else begin integer p;
449     x := x + 1;
450     p := ParenHeight(h,d) - 1;
451     for i := -p+1 : p-1 do PutChar(GetLine(disparray,y+i),x,'!|);
452     PutChar(GetLine(disparray,y+p),x,'!\);
453     PutChar(GetLine(disparray,y-p),x,'!/);
454   end$
455
456symbolic inline procedure InsertParens(disparray,x1,x2,y,h,d);
457  << InsertLeftParen(disparray,x1,y,h,d);
458     InsertRightParen(disparray,x2,y,h,d) >>$
459
460
461symbolic procedure InsertDisplayBox(box,disparray,x,y);
462  begin integer h,d,w,l,argl; scalar u,v;
463    h := BoxHeight box; d := BoxDepth box; w := BoxWidth box;
464    if IsAtomDisplayBox box then <<
465      u := explode2 BoxExpression box;
466      v := GetLine(disparray,y);
467      for i := 0 : w-1 do
468        << PutChar(v,x+i,car u); u := cdr u >> >>
469     else if IsSpecialDisplayBox box
470      then apply(get(BoxOperator box,'InsertDisplayBox),
471                 list(box,disparray,x,y))
472     else if not null get(BoxOperator box,'infix)
473      then InsertInfixDisplayBox(box,disparray,x,y)
474     else <<
475      u := explode2 BoxOperator box;
476      l := length u;
477      v := GetLine(disparray,y);
478      for i := 0 : l-1 do << PutChar(v,x+i,car u); u := cdr u >>;
479      PutChar(v,x+l,'!();
480      argl := BoxArgList box;
481      while not null cdr argl do begin integer x1,y1;
482        x1 := x + car car argl;
483        y1 := y + cadr car argl;
484        InsertDisplayBox(caddr car argl,disparray,x1,y1);
485        PutChar(v,x1 + BoxWidth caddr car argl,'!,);
486        argl := cdr argl;
487      end;
488      InsertDisplayBox(caddr car argl,disparray,
489                       x + car car argl,y + cadr car argl);
490      PutChar(v,x+w-1,'!)) >>
491  end$
492
493symbolic procedure MakeDisplayArray box;
494  begin scalar x,y; integer h,d,w;
495    h := BoxHeight box; d := BoxDepth box; w := BoxWidth box;
496    x := mkvect (h+d-1);
497    for i := 0 : h+d-1 do <<
498      y := mkvect (w-1);
499      for j := 0 : w-1 do PutChar(y,j,'! );
500      PutChar(x,i,y) >>;
501    InsertDisplayBox(box,x,0,0) where !*DisplayArrayDepth!* := d;
502    return x
503  end$
504
505symbolic procedure InsertInfixDisplayBox(box,disparray,x,y);
506  if null cddr BoxExpression box
507    then InsertUnaryDisplayBox(box,disparray,x,y)
508   else InsertNaryDisplayBox(box,disparray,x,y)$
509
510
511symbolic procedure InsertUnaryDisplayBox(box,disparray,x,y);
512  begin integer h,d,w,l,x1,y1,x2; scalar u,v,arg,b;
513    h := BoxHeight box; d := BoxDepth box; w := BoxWidth box;
514    u := get(BoxOperator box,'prtch);
515    u := explode2 if null u then BoxOperator box else u;
516    if flagp(BoxOperator box,'spaced)
517      then u := '!  . reversip ('!  . reversip u);
518    l := length u - 1;
519    v := GetLine(disparray,y);
520    arg := car BoxArgList box;
521    if BoxIsParenthesized box then <<
522      InsertParens(disparray,x,x2,y,h,d);
523      x1 := x + ParenWidth(h,d);
524      x2 := x + w - ParenWidth(h,d) >>
525     else << x1 := x; x2 := x + w >>;
526    for i := 0 : l do PutChar(v,x1+i,nth(u,i+1));
527    InsertDisplayBox(caddr arg,disparray,x + car arg,y + cadr arg);
528  end$
529
530symbolic procedure InsertNaryDisplayBox(box,disparray,x,y);
531  begin integer h,d,w,l,x1,y1,x2,op; scalar u,v,argl,b;
532    h := BoxHeight box; d := BoxDepth box; w := BoxWidth box;
533    op := BoxOperator box;
534    u := get(op,'prtch);
535    u := explode2 if null u then op else u;
536    if flagp(op,'spaced)
537      then u := '!  . reversip ('!  . reversip u);
538    l := length u - 1;
539    v := GetLine(disparray,y);
540    argl := BoxArgList box;
541    while not null cdr argl do <<
542      x1 := x + car car argl;
543      y1 := y + cadr car argl;
544      b := caddr car argl;
545      argl := cdr argl;
546      InsertDisplayBox(b,disparray,x1,y1);
547      x2 := x1 + BoxWidth b;
548      if not (op eq get(BoxOperator caddr car argl,'alt))
549        then for i := 0 : l do PutChar(v,x2+i,nth(u,i+1)) >>;
550    x1 := x + car car argl;
551    InsertDisplayBox(caddr car argl,disparray,x1,y + cadr car argl);
552    if BoxIsParenthesized box then
553      InsertParens(disparray,x,x1 + BoxWidth caddr car argl,y,h,d);
554  end$
555
556
557symbolic procedure InsertExptDisplayBox(box,disparray,x,y);
558  << InsertDisplayBox(caddr car BoxArgList box,disparray,x,y);
559     InsertDisplayBox(caddr cadr BoxArgList box,disparray,
560                      x + car cadr BoxArgList box,
561                      y + cadr cadr BoxArgList box) >>$
562
563put('expt,'InsertDisplayBox,'InsertExptDisplayBox)$
564
565
566symbolic procedure InsertQuotientDisplayBox(box,disparray,x,y);
567  begin scalar numer,denom; integer first,last;
568    numer := car BoxArgList box;
569    denom := cadr BoxArgList box;
570    InsertDisplayBox(caddr numer,disparray,
571                     x + car numer,y + cadr numer);
572    InsertDisplayBox(caddr denom,disparray,
573                     x + car denom,y + cadr denom);
574    first := if BoxIsParenthesized box
575               then ParenWidth(BoxHeight box,BoxDepth box)
576              else 0;
577    last := BoxWidth box - first - 1;
578    for i := first : last do
579      PutChar(GetLine(disparray,y),x + i,'_)
580  end$
581
582put('quotient,'InsertDisplayBox,'InsertQuotientDisplayBox)$
583
584
585symbolic procedure InsertIntDisplayBox(box,disparray,x,y);
586  begin integer h,d,p;
587    h := BoxHeight box; d := BoxDepth box;
588    p := ParenHeight(h,d) - 1;
589    for i := -p+1 : p-1 do
590      PutChar(GetLine(disparray,y+i),x+1,'!|);
591    PutChar(GetLine(disparray,y+p),x+1,'!/);
592    PutChar(GetLine(disparray,y-p),x+1,'!/);
593    InsertDisplayBox(caddr car BoxArgList box,disparray,x+3,y);
594    p := car cadr BoxArgList box;
595    PutChar(GetLine(disparray,y),p-1,'d);
596    InsertDisplayBox(caddr cadr BoxArgList box,disparray,x+p,y);
597    if BoxIsParenthesized box then
598      InsertParens(disparray,x,x+p+BoxWidth cadr BoxArgList box,y,h,d)
599  end$
600
601
602put('int,'InsertDisplayBox,'InsertIntDisplayBox)$
603
604
605symbolic procedure PrintDisplayArray disparray;
606  << for i := upbv disparray step -1 until 0 do begin scalar v;
607       v := getv(disparray,i);
608       terpri();
609       for j := 0 : upbv v do princ getv(v,j)
610     end;
611     terpri() >>$
612
613fluid '(!*LeftMargin!* !*RightMargin!*)$
614
615!*LeftMargin!* := 0$
616!*RightMargin!* := linelength nil$
617
618symbolic procedure PutChar(line,x,c);
619  if x>=!*LeftMargin!* and x<!*RightMargin!*
620    then putv(line,x-!*LeftMargin!*,c)$
621
622symbolic procedure
623  MakePartialDisplayArray(box,!*LeftMargin!*,!*RightMargin!*);
624    begin scalar x,y; integer h,d,w;
625      h := BoxHeight box; d := BoxDepth box;
626      w := !*RightMargin!* - !*LeftMargin!*;
627      x := mkvect (h+d-1);
628      for i := 0 : h+d-1 do <<
629        y := mkvect (w-1);
630      for j := 0 : w-1 do putv(y,j,'! );
631      putv(x,i,y) >>;
632      InsertDisplayBox(box,x,0,0) where !*DisplayArrayDepth!* := d;
633      return x
634    end$
635
636symbolic procedure PrintPrefixForm u;
637  begin scalar b,breaks; integer l,r;
638    b := BuildDisplayBox(u,nil);
639    breaks := car BreakDisplayBox(b,linelength nil);
640    if null breaks then
641      PrintDisplayArray MakePartialDisplayArray(b,0,BoxWidth b)
642     else <<
643      breaks := append(breaks,list BoxWidth b);
644      l := 0;
645      while breaks do <<
646        r := car breaks;
647        PrintDisplayArray MakePartialDisplayArray(b,l,r);
648        l := r;
649        breaks := cdr breaks >> >>
650  end$
651
652
653% I will put some test cases in here...
654
655symbolic procedure testatom(id, font, size, filename);
656  begin
657    scalar a, b, ff;
658    CurrentFont := get(compress explodec font, 'font_number);
659    CurrentSize := size;
660    print list(font, CurrentFont, CurrentSize);
661    b := MeasureAtom id;
662    ff := open(filename, 'output);
663    a := wrs ff;
664    princ "deffont 1 "; princ font; princ " "; princ size; printc ";";
665    for each c in b do <<
666      princ "put 1 ";
667      prin car c;
668      princ " 0 ";
669      prin cdr c;
670      princ ";";
671      if 0x20 < cdr c and cdr c < 0x7f then <<
672        while posn() < 20 do princ " ";
673        princ " % ";
674        princ list2string list cdr c >>;
675      terpri() >>;
676    wrs a;
677    close ff;
678  end;
679
680!*ligatures := nil;
681
682testatom(
683    "Triffle and sponge fingers flip with difficulty! VA AV AA VV ",
684    "General",
685    '24,
686    "burning.dat");
687
688!*ligatures := t;
689
690testatom(
691    "Triffle and sponge fingers flip with difficulty! VA AV AA VV ",
692    "General",
693    '24,
694    "burning-lig.dat");
695
696testatom(
697    "The boy stood on the burning deck, whence all but he had fled!",
698    "cmuntt",
699    '30,
700    "burning1.dat");
701
702end;
703