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