1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34--Modified JHD February 1993: see files miscout.input for some tests of this 35-- General principle is that maprin0 is the top-level routine, 36-- which calls maprinChk to print the object (placing certain large 37-- matrices on a look-aside list), then calls maprinRows to print these. 38-- These prints call maprinChk recursively, and maprinChk has to ensure that 39-- we do not end up in an infinite recursion: matrix1 = matrix2 ... 40 41--% Output display routines 42 43DEFPARAMETER($plainRTspecialCharacters, [ 44 '_+, -- upper left corner (+) 45 '_+, -- upper right corner (+) 46 '_+, -- lower left corner (+) 47 '_+, -- lower right corner (+) 48 '_|, -- vertical bar 49 '_-, -- horizontal bar (-) 50 '_?, -- APL quad (?) 51 '_[, -- left bracket 52 '_], -- right bracket 53 '_{, -- left brace 54 '_}, -- right brace 55 '_+, -- top box tee (+) 56 '_+, -- bottom box tee (+) 57 '_+, -- right box tee (+) 58 '_+, -- left box tee (+) 59 '_+, -- center box tee (+) 60 '_\ -- back slash 61 ]) 62 63DEFPARAMETER($tallPar, false) 64DEFCONST(MATBORCH, '"*") 65DEFCONST($EmptyString, '"") 66DEFCONST($DoubleQuote, '"_"") 67 68DEFVAR($algebraFormat, true) -- produce 2-d algebra output 69DEFVAR($fortranFormat, false) -- if true produce fortran output 70DEFVAR($htmlFormat, false) -- if true produce HTML output 71DEFVAR($mathmlFormat, false) -- if true produce Math ML output 72DEFVAR($texFormat, false) -- if true produce tex output 73DEFVAR($texmacsFormat, false) -- if true produce Texmacs output 74DEFVAR($formattedFormat, false) -- if true produce formatted output 75 76makeCharacter n == INTERN(NUM2USTR(n)) 77 78DEFPARAMETER($RTspecialCharacters, [ 79 makeCharacter 9484, -- upper left corner (+) 80 makeCharacter 9488, -- upper right corner (+) 81 makeCharacter 9492, -- lower left corner (+) 82 makeCharacter 9496, -- lower right corner (+) 83 makeCharacter 9474, -- vertical bar 84 makeCharacter 9472, -- horizontal bar (-) 85 -- $quadSymbol, -- APL quad (?) 86 '_?, -- APL quad 87 '_[, -- left bracket 88 '_], -- right bracket 89 '_{, -- left brace 90 '_}, -- right brace 91 makeCharacter 9516, -- top box tee (+) 92 makeCharacter 9524, -- bottom box tee (+) 93 makeCharacter 9508, -- right box tee (+) 94 makeCharacter 9500, -- left box tee (+) 95 makeCharacter 9532, -- center box tee (+) 96 '_\ -- back slash 97 ]) 98 99DEFPARAMETER($specialCharacters, $plainRTspecialCharacters) 100 101DEFPARAMETER($specialCharacterAlist, '( 102 (ulc . 0)_ 103 (urc . 1)_ 104 (llc . 2)_ 105 (lrc . 3)_ 106 (vbar . 4)_ 107 (hbar . 5)_ 108 (quad . 6)_ 109 (lbrk . 7)_ 110 (rbrk . 8)_ 111 (lbrc . 9)_ 112 (rbrc . 10)_ 113 (ttee . 11)_ 114 (btee . 12)_ 115 (rtee . 13)_ 116 (ltee . 14)_ 117 (ctee . 15)_ 118 (bslash . 16)_ 119 )) 120 121$collectOutput := nil 122 123get_lisp_stream(fs) == REST(fs) 124 125get_algebra_stream() == get_lisp_stream($algebraOutputStream) 126 127get_fortran_stream() == get_lisp_stream($fortranOutputStream) 128 129get_mathml_stream() == get_lisp_stream($mathmlOutputStream) 130 131get_texmacs_stream() == get_lisp_stream($texmacsOutputStream) 132 133get_html_stream() == get_lisp_stream($htmlOutputStream) 134 135get_tex_stream() == get_lisp_stream($texOutputStream) 136 137get_formatted_stream() == get_lisp_stream($formattedOutputStream) 138 139specialChar(symbol) == 140 -- looks up symbol in $specialCharacterAlist, gets the index 141 -- into the EBCDIC table, and returns the appropriate character 142 null (code := IFCDR ASSQ(symbol,$specialCharacterAlist)) => '"?" 143 ELT($specialCharacters,code) 144 145rbrkSch() == PNAME specialChar 'rbrk 146lbrkSch() == PNAME specialChar 'lbrk 147quadSch() == PNAME specialChar 'quad 148 149isBinaryInfix x == 150 x in '(_= _+ _- _* _/ _*_* _^ "=" "+" "-" "*" "/" "**" "^") 151 152stringApp([.,u],x,y,d) == 153 appChar(STRCONC($DoubleQuote,atom2String u,$DoubleQuote),x,y,d) 154 155stringWidth u == 156 u is [.,u] or THROW('outputFailure,'outputFailure) 157 2+#u 158 159obj2String o == 160 atom o => 161 STRINGP o => o 162 o = " " => '" " 163 o = ")" => '")" 164 o = "(" => '"(" 165 STRINGIMAGE o 166 concatenateStringList([obj2String o' for o' in o]) 167 168APP(u,x,y,d) == 169 atom u => appChar(atom2String u,x,y,d) 170 u is [[op,:.],a] and (s:= GETL(op,'PREFIXOP)) => 171 GETL(op,'isSuffix) => appChar(s,x+WIDTH a,y,APP(a,x,y,d)) 172 APP(a,x+#s,y,appChar(s,x,y,d)) 173 u is [[id,:.],:.] => 174 fn := GETL(id,'APP) => FUNCALL(fn,u,x,y,d) 175 not NUMBERP id and (d':= appInfix(u,x,y,d))=> d' 176 appelse(u,x,y,d) 177 appelse(u,x,y,d) 178 179atom2String x == 180 IDENTP x => PNAME x 181 STRINGP x => x 182 stringer x 183 184-- General convention in the "app..." functions: 185-- Added from an attempt to fix bugs by JHD: 2 Aug 89 186-- the first argument is what has to be printed 187-- the second - x - is the horizontal distance along the page 188-- at which to start 189-- the third - y - is some vertical hacking control 190-- the fourth - d - is the "layout" so far 191-- these functions return an updated "layout so far" in general 192 193appChar(string,x,y,d) == 194 if CHARP string then string := PNAME string 195 line:= LASSOC(y,d) => 196 RPLACSTR(line, x, n := #string, string, 0, n) 197 d 198 appChar(string, x, y, nconc(d, 199 [[y, :make_full_CVEC(10 + $LINELENGTH + $MARGIN, " ")]])) 200 201mathprintWithNumber x == 202 ioHook("startAlgebraOutput") 203 x:= outputTran2 x 204 maprin 205 $IOindex => ['EQUATNUM,$IOindex,x] 206 x 207 ioHook("endOfAlgebraOutput") 208 209mathprint x == 210 x := outputTran2 x 211 maprin x 212 213sayMath u == 214 for x in u repeat acc:= concat(acc,linearFormatName x) 215 sayALGEBRA acc 216 217--% Output transformations 218 219outputTran2 x == 220 ot2_fun := getFunctionFromDomain1("precondition", '(OutputFormTools), 221 $OutputForm, [$OutputForm]) 222 SPADCALL(x, ot2_fun) 223 224outputTran x == 225 atom x => x 226 x is [c,var,mode] and c in '(_pretend _: _:_: _@) => 227 var := outputTran var 228 if PAIRP var then var := ['PAREN,var] 229 ['CONCATB,var,c,obj2String prefix2String mode] 230 x is ['ADEF,vars,.,.,body] => 231 vars := 232 vars is [x] => x 233 ['Tuple,:vars] 234 outputTran ["+->", vars, body] 235 x is ['matrix,['construct,c]] and 236 c is ['COLLECT,:m,d] and d is ['construct,e] and e is ['COLLECT,:.] => 237 outputTran ['COLLECT,:m,e] 238 x is ['LIST,:l] => outputTran ['BRACKET,['AGGLST,:l]] 239 x is ['SPADMAP, :l] => BREAK() 240 x is ['brace, :l] => 241 ['BRACE, ['AGGLST,:[outputTran y for y in l]]] 242 x is ["return", l] => ["return", outputTran l] 243 244 x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or 245 domain is ['Float]) and INTEGERP x and INTEGERP y and INTEGERP z and 246 z > 0 and (float := getFunctionFromDomain("float",domain,[$Integer,$Integer,$PositiveInteger])) => 247 f := SPADCALL(x,y,z,float) 248 o := coerceInteractive(mkObjWrap(f, domain), '(OutputForm)) 249 objValUnwrap o 250 [op, :l] := x 251 x is ['break,:.] => 'break 252 253 op is ["$elt",targ,fun] or not $InteractiveMode and op is ["elt",targ,fun] => 254 -- l has the args 255 targ' := obj2String prefix2String targ 256 if 2 = #targ then targ' := ['PAREN,targ'] 257 ['CONCAT,outputTran [fun,:l],'"$",targ'] 258 x is ["$elt",targ,c] or not $InteractiveMode and x is ["elt",targ,c] => 259 targ' := obj2String prefix2String targ 260 if 2 = #targ then targ' := ['PAREN,targ'] 261 ['CONCAT,outputTran c,'"$",targ'] 262 263 op = 'IF => outputTranIf x 264 op = 'COLLECT => outputTranCollect x 265 op = 'REDUCE => outputTranReduce x 266 op = 'REPEAT => outputTranRepeat x 267 op = 'SEQ => outputTranSEQ x 268 op in '(cons nconc) => outputConstructTran x 269 l:= [outputTran y for y in l] 270 op="|" and l is [["Tuple",:u],pred] => 271 ['PAREN,["|",['AGGLST,:l],pred]] 272 op='Tuple => ['PAREN,['AGGLST,:l]] 273 op='LISTOF => ['AGGLST,:l] 274 [outputTran op,:l] 275 276outputTranSEQ ['SEQ,:l,exitform] == 277 if exitform is ['exit,.,a] then exitform := a 278 ['SC,:[outputTran x for x in l],outputTran exitform] 279 280outputTranIf ['IF,x,y,z] == 281 y = 'noBranch => 282 ["CONCATB", "if", ["CONCATB", "not", outputTran x], "then", outputTran z] 283 z = 'noBranch => 284 ["CONCATB", "if", outputTran x, "then", outputTran y] 285 y' := outputTran y 286 z' := outputTran z 287 ['CONCATB, "if", outputTran x, 288 ['SC,['CONCATB, "then", y'], ['CONCATB, "else", z']]] 289 290outputTranAnon(x) == 291 not(x is ["+->", vars, body]) => BREAK() 292 outputTran(x) 293 294outputMapTran(op, x) == 295 not(x is ['SPADMAP, :l]) => BREAK() 296 null l => NIL -- should not happen 297 298 -- display subscripts linearly 299 $linearFormatScripts : local := true 300 301 -- get the real names of the parameters 302 alias := get(op, 'alias, $InteractiveFrame) 303 304 rest l => -- if multiple forms, call repeatedly 305 ['SC, :[outputMapTran0(op, ll, alias) for ll in l]] 306 outputMapTran0(op, first l, alias) 307 308outputMapTran0(op, argDef, alias) == 309 arg := first argDef 310 def := rest argDef 311 [arg',:def'] := simplifyMapPattern(argDef,alias) 312 arg' := outputTran arg' 313 if null arg' then arg' := '"()" 314 ['CONCATB, op, outputTran arg', "==", outputTran def'] 315 316outputTranReduce ['REDUCE,op,.,body] == 317 ['CONCAT,op,"/",outputTran body] 318 319outputTranRepeat ["REPEAT",:itl,body] == 320 body' := outputTran body 321 itl => 322 itlist:= outputTranIteration itl 323 ['CONCATB,itlist,'repeat,body'] 324 ['CONCATB,'repeat,body'] 325 326outputTranCollect [.,:itl,body] == 327 itlist:= outputTranIteration itl 328 ['BRACKET,['CONCATB,outputTran body,itlist]] 329 330outputTranIteration itl == 331 null rest itl => outputTranIterate first itl 332 ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl] 333 334outputTranIterate x == 335 x is ['STEP,n,init,step,:final] => 336 init' := outputTran init 337 if LISTP init then init' := ['PAREN,init'] 338 final' := 339 final => 340 LISTP first final => [['PAREN,outputTran first final]] 341 [outputTran first final] 342 NIL 343 ['STEP,outputTran n,init',outputTran step,:final'] 344 x is ["IN",n,s] => ["IN",outputTran n,outputTran s] 345 x is [op,p] and op in '(_| UNTIL WHILE) => 346 op:= DOWNCASE op 347 ['CONCATB,op,outputTran p] 348 throwKeyedMsg("S2IX0008",['outputTranIterate,['"illegal iterate: ",x]]) 349 350outputConstructTran x == 351 x is [op,a,b] => 352 a:= outputTran a 353 b:= outputTran b 354 op="cons" => 355 b is ['construct,:l] => ['construct,a,:l] 356 ['BRACKET,['AGGLST,:[a,[":",b]]]] 357 op="nconc" => 358 aPart := 359 a is ['construct,c] and c is ['SEGMENT,:.] => c 360 [":",a] 361 b is ['construct,:l] => ['construct,aPart,:l] 362 ['BRACKET,['AGGLST,aPart,[":",b]]] 363 [op,a,b] 364 atom x => x 365 [outputTran first x,:outputConstructTran rest x] 366 367tensorApp(u,x,y,d) == 368 rightPrec:= getOpBindingPower("*","Led","right") 369 firstTime:= true 370 for arg in rest u repeat 371 op:= keyp arg 372 if not firstTime then 373 opString:= GETL('TENSOR,"INFIXOP") or '"#" 374 d:= APP(opString,x,y,d) 375 x:= x + #opString 376 [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg 377 wasSimple := atom arg and not NUMBERP arg 378 wasQuotient:= isQuotient op 379 wasNumber:= NUMBERP arg 380 lastOp := op 381 firstTime:= nil 382 d 383 384tensorWidth u == 385 rightPrec:= getOpBindingPower("*","Led","right") 386 firstTime:= true 387 w:= 0 388 for arg in rest u repeat 389 op:= keyp arg 390 if not firstTime then 391 opString:= GETL('TENSOR,"INFIXOP") or '"#" 392 w:= w + #opString 393 if infixArgNeedsParens(arg, rightPrec, "left") then w:= w+2 394 w:= w+WIDTH arg 395 wasSimple := atom arg and not NUMBERP arg 396 wasQuotient:= isQuotient op 397 wasNumber:= NUMBERP arg 398 firstTime:= nil 399 w 400 401timesApp(u,x,y,d) == 402 rightPrec:= getOpBindingPower("*","Led","right") 403 firstTime:= true 404 for arg in rest u repeat 405 op:= keyp arg 406 if not firstTime and (needBlankForRoot(lastOp,op,arg) or 407 needStar(wasSimple,wasQuotient,wasNumber,arg,op) or 408 wasNumber and op = 'ROOT and subspan arg = 1) then 409 d:= APP(BLANK,x,y,d) 410 x:= x+1 411 [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg 412 wasSimple := atom arg and not NUMBERP arg or keyp arg = "OVERBAR" 413 wasQuotient:= isQuotient op 414 wasNumber:= NUMBERP arg 415 lastOp := op 416 firstTime:= nil 417 d 418 419needBlankForRoot(lastOp,op,arg) == 420 lastOp ~= "^" and lastOp ~= "**" and not(subspan(arg)>0) => false 421 op = "**" and keyp CADR arg = 'ROOT => true 422 op = "^" and keyp CADR arg = 'ROOT => true 423 op = 'ROOT and CDDR arg => true 424 false 425 426stepApp([.,a,init,one,:optFinal],x,y,d) == 427 d:= appChar('"for ",x,y,d) 428 d:= APP(a,w:=x+4,y,d) 429 d:= appChar('" in ",w:=w+WIDTH a,y,d) 430 d:= APP(init,w:=w+4,y,d) 431 d:= APP('"..",w:=w+WIDTH init,y,d) 432 if optFinal then d:= APP(first optFinal,w+2,y,d) 433 d 434 435stepSub [.,a,init,one,:optFinal] == 436 m:= MAX(subspan a,subspan init) 437 optFinal => MAX(m,subspan first optFinal) 438 m 439 440stepSuper [.,a,init,one,:optFinal] == 441 m:= MAX(superspan a,superspan init) 442 optFinal => MAX(m,superspan first optFinal) 443 m 444 445stepWidth [.,a,init,one,:optFinal] == 446 10+WIDTH a+WIDTH init+(optFinal => WIDTH first optFinal; 0) 447 448inApp([.,a,s],x,y,d) == --for [IN,a,s] 449 d:= appChar('"for ",x,y,d) 450 d:= APP(a,x+4,y,d) 451 d:= appChar('" in ",x+WIDTH a+4,y,d) 452 APP(s,x+WIDTH a+8,y,d) 453 454inSub [.,a,s] == MAX(subspan a,subspan s) 455 456inSuper [.,a,s] == MAX(superspan a,superspan s) 457 458inWidth [.,a,s] == 8+WIDTH a+WIDTH s 459 460centerApp([.,u],x,y,d) == 461 d := APP(u,x,y,d) 462 463concatApp([.,:l],x,y,d) == concatApp1(l,x,y,d,0) 464 465concatbApp([.,:l],x,y,d) == concatApp1(l,x,y,d,1) 466 467concatApp1(l,x,y,d,n) == 468 for u in l repeat 469 d:= APP(u,x,y,d) 470 x:=x+WIDTH u+n 471 d 472 473concatSub [.,:l] == "MAX"/[subspan x for x in l] 474 475concatSuper [.,:l] == "MAX"/[superspan x for x in l] 476 477concatWidth [.,:l] == +/[WIDTH x for x in l] 478 479concatbWidth [.,:l] == 480 null l => 0 481 +/[1+WIDTH x for x in l]-1 482 483exptApp([.,a,b],x,y,d) == 484 pren:= exptNeedsPren a 485 d:= 486 pren => appparu(a,x,y,d) 487 APP(a,x,y,d) 488 x':= x+WIDTH a+(pren => 2;0) 489 y':= 1+y+superspan a+subspan b + (0=superspan a => 0; -1) 490 APP(b,x',y',d) 491 492exptNeedsPren a == 493 atom a and null (INTEGERP a and a < 0) => false 494 key:= keyp a 495 key = "OVER" or key = "SIGMA" or key = "SIGMA2" or key = "PI" 496 or key = "PI2" => true 497 (key="SUB") or (null GETL(key,"Nud") and null GETL(key,"Led")) => false 498 true 499 500exptSub u == subspan CADR u 501 502exptSuper [.,a,b] == superspan a+height b+(superspan a=0 => 0;-1) 503 504exptWidth [.,a,b] == WIDTH a+WIDTH b+(exptNeedsPren a => 2;0) 505 506needStar(wasSimple,wasQuotient,wasNumber,cur,op) == 507 wasNumber or wasQuotient or isQuotient op => true 508 wasSimple => 509 atom cur or keyp cur="SUB" or keyp cur = "OVERBAR" or op="**" or 510 op = "^" or (atom op and not NUMBERP op and not GETL(op,"APP")) 511 -- deal with cases like "x*f'(x)" 512 or (keyp op = "PRIME" or keyp op = "SUB") 513 514isQuotient op == 515 op="/" or op="OVER" 516 517timesWidth u == 518 rightPrec:= getOpBindingPower("*","Led","right") 519 firstTime:= true 520 w:= 0 521 for arg in rest u repeat 522 op:= keyp arg 523 if not firstTime and (needBlankForRoot(lastOp,op,arg) or 524 needStar(wasSimple,wasQuotient,wasNumber,arg,op) or 525 (wasNumber and op = 'ROOT and subspan arg = 1)) then 526 w:= w+1 527 if infixArgNeedsParens(arg, rightPrec, "left") then w:= w+2 528 w:= w+WIDTH arg 529 wasSimple := atom arg and not NUMBERP arg or keyp arg = "OVERBAR" 530 wasQuotient:= isQuotient op 531 wasNumber:= NUMBERP arg 532 lastOp := op 533 firstTime:= nil 534 w 535 536plusApp([.,frst,:rst],x,y,d) == 537 appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d)) 538 539appSum(u,x,y,d) == 540 for arg in u repeat 541 infixOp:= 542 syminusp arg => "-" 543 "+" 544 opString:= GETL(infixOp,"INFIXOP") or '"," 545 d:= APP(opString,x,y,d) 546 x:= x+WIDTH opString 547 arg:= absym arg --negate a neg. number or remove leading "-" 548 rightPrec:= getOpBindingPower(infixOp,"Led","right") 549 if infixOp = "-" then rightPrec:=rightPrec +1 550 -- that +1 added JHD 2 Aug 89 to prevent x-(y+z) printing as x-y+z 551 -- Sutor found the example: 552 -- )cl all 553 -- p : P[x] P I := x - y - z 554 -- p :: P[x] FR P I 555 -- trailingCoef % 556 [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg 557 d 558 559appInfix(e,x,y,d) == 560 op := keyp e 561 leftPrec:= getOpBindingPower(op,"Led","left") 562 leftPrec = 1000 => return nil --no infix operator is allowed default value 563 rightPrec:= getOpBindingPower(op,"Led","right") 564 #e < 2 => throwKeyedMsg("S2IX0008",['appInfix, 565 '"fewer than 2 arguments to an infix function"]) 566 opString:= GETL(op,"INFIXOP") or '"," 567 opWidth:= WIDTH opString 568 [.,frst,:rst]:= e 569 null rst => 570 GETL(op,"isSuffix") => 571 [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) 572 d:= appChar(opString,x,y,d) 573 THROW('outputFailure,'outputFailure) 574 [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) --app in left arg 575 for arg in rst repeat 576 d:= appChar(opString,x,y,d) --app in the infix operator 577 x:= x+opWidth 578 [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",opString) --app in right arg 579 d 580 581appconc(d,x,y,w) == NCONC(d,[[[x,:y],:w]]) 582 583infixArgNeedsParens(arg, prec, leftOrRight) == 584 prec > getBindingPowerOf(leftOrRight, arg) + 1 585 586appInfixArg(u,x,y,d,prec,leftOrRight,string) == 587 insertPrensIfTrue:= infixArgNeedsParens(u,prec,leftOrRight) 588 d:= 589 insertPrensIfTrue => appparu(u,x,y,d) 590 APP(u,x,y,d) 591 x:= x+WIDTH u 592 if string then d:= appconc(d,x,y,string) 593 [d,(insertPrensIfTrue => x+2; x)] 594 595getBindingPowerOf(key,x) == 596 --binding powers can be found in file NEWAUX LISP 597 x is ['REDUCE,:.] => (key='left => 130; key='right => 0) 598 x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) 599 x is ["COND",:.] => (key="left" => 130; key="right" => 0) 600 x is [op,:argl] => 601 if op is [a,:.] then op:= a 602 op = 'SLASH => getBindingPowerOf(key,["/",:argl]) - 1 603 op = 'OVER => getBindingPowerOf(key,["/",:argl]) 604 (n:= #argl)=1 => 605 key="left" and (m:= getOpBindingPower(op,"Nud","left")) => m 606 key="right" and (m:= getOpBindingPower(op,"Nud","right")) => m 607 1000 608 n>1 => 609 key="left" and (m:= getOpBindingPower(op,"Led","left")) => m 610 key="right" and (m:= getOpBindingPower(op,"Led","right")) => m 611 op="ELT" => 1002 612 1000 613 1000 614 1002 615 616getOpBindingPower(op,LedOrNud,leftOrRight) == 617 if op in '(SLASH OVER) then op := "/" 618 not(SYMBOLP(op)) => 1000 619 exception:= 620 leftOrRight="left" => 0 621 105 622 bp:= 623 leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) 624 rightBindingPowerOf(op,LedOrNud) 625 bp~=exception => bp 626 1000 627 628--% Brackets 629bracketApp(u,x,y,d) == 630 u is [.,u] or THROW('outputFailure,'outputFailure) 631 d:= appChar(specialChar 'lbrk,x,y,d) 632 d:=APP(u,x+1,y,d) 633 appChar(specialChar 'rbrk,x+1+WIDTH u,y,d) 634 635--% Braces 636braceApp(u,x,y,d) == 637 u is [.,u] or THROW('outputFailure,'outputFailure) 638 d:= appChar(specialChar 'lbrc,x,y,d) 639 d:=APP(u,x+1,y,d) 640 appChar(specialChar 'rbrc,x+1+WIDTH u,y,d) 641 642--% Aggregates 643aggWidth u == 644 rest u is [a,:l] => WIDTH a + +/[2+WIDTH x for x in l] 645 0 646 647aggSub u == subspan rest u 648 649aggSuper u == superspan rest u 650 651aggApp(u,x,y,d) == aggregateApp(rest u,x,y,d,", ") 652 653aggregateApp(u, x, y, d, s) == agg_app(u, x, y, d, s, WIDTH(s)) 654 655agg_app(u, x, y, d, s, width_s) == 656 if u is [a,:l] then 657 d:= APP(a,x,y,d) 658 x:= x+WIDTH a 659 for b in l repeat 660 d := APP(s, x, y, d) 661 d := APP(b, x + width_s, y, d) 662 x := x + width_s + WIDTH(b) 663 d 664 665--% Function to compute Width 666 667outformWidth u == --WIDTH as called from OUTFORM to do a COPY 668 STRINGP u => #u 669 atom u => # atom2String u 670 WIDTH COPY u 671 672WIDTH u == 673 STRINGP u => #u 674 INTEGERP u => 675 if (u < 0) then 676 negative := 1 677 u := -u 678 else 679 negative := 0 680 681 -- Try and be fairly exact for smallish integers: 682 u < 100000000 => 683 l := 684 u < 10 => 1 685 u < 100 => 2 686 u < 1000 => 3 687 u < 10000 => 4 688 u < 100000 => 5 689 u < 1000000 => 6 690 u < 10000000 => 7 691 8 692 l + negative 693 k := INTEGER_-LENGTH(u) 694 k > MOST_-POSITIVE_-DOUBLE_-FLOAT => 695 SAY("Number too big") 696 THROW('outputFailure,'outputFailure) 697 698 if (k < 61) then 699 l10 := LOG10 (FLOAT (u, 1.0)) 700 else 701 su := ASH(u, - (k - 54)) 702 l10 := LOG10 (FLOAT (su, 1.0)) 703 -- we want full double precision here because the second 704 -- term may be much bigger than the first one, so we use 705 -- very precise estimate of log(2)/log(10) 706 + 0.301029995663981195213738894724 * FLOAT ((k - 54), 1.0) 707 -- Add bias to l10 to have only one-sided error 708 l10i := FLOOR(l10 + 1.0e-9) 709 710 l10i < 10000 => 711 -- Check if sure 712 l10 - 1.0e-9 > l10i => 1 + negative + l10i 713 u < EXPT(10, l10i) => negative + l10i 714 1 + negative + l10i 715 716 -- width is very large, it would be expensive to compute it 717 -- accurately, so we just make sure that we overestimate. 718 -- l10 should have about 14 digits of accuracy 719 1 + negative + FLOOR(l10 * (1.0 + 1.0e-12)) 720 721 atom u => # atom2String u 722 putWidth u is [[.,:n],:.] => n 723 THROW('outputFailure,'outputFailure) 724 725putWidth u == 726 atom u or u is [[.,:n],:.] and NUMBERP n => u 727 op:= keyp u 728--NUMBERP op => nil 729 leftPrec:= getBindingPowerOf("left",u) 730 rightPrec:= getBindingPowerOf("right",u) 731 [firstEl,:l] := u 732 interSpace:= 733 GETL(firstEl,"INFIXOP") => 0 734 1 735 argsWidth:= 736 l is [firstArg,:restArg] => 737 RPLACA(rest u,putWidth firstArg) 738 for y in tails restArg repeat RPLACA(y,putWidth first y) 739 widthFirstArg:= 740 0=interSpace and infixArgNeedsParens(firstArg,leftPrec,"right")=> 741 2+WIDTH firstArg 742 WIDTH firstArg 743 widthFirstArg + +/[interSpace+w for x in restArg] where w == 744 0=interSpace and infixArgNeedsParens(x, rightPrec, "left") => 745 2+WIDTH x 746 WIDTH x 747 0 748 newFirst:= 749 atom (oldFirst:= first u) => 750 fn:= GETL(oldFirst,"WIDTH") => 751 [oldFirst,:FUNCALL(fn,[oldFirst,:l])] 752 if l then ll := rest l else ll := nil 753 [oldFirst,:opWidth(oldFirst,ll)+argsWidth] 754 [putWidth oldFirst,:2+WIDTH oldFirst+argsWidth] 755 RPLACA(u,newFirst) 756 u 757 758opWidth(op,has2Arguments) == 759 op = "EQUATNUM" => 4 760 NUMBERP op => 2+SIZE STRINGIMAGE op 761 if null has2Arguments then 762 a := GETL(op, "PREFIXOP") => return SIZE a 763 else 764 a := GETL(op, "INFIXOP") => return SIZE a 765 STRINGP op => 2 + # op 766 2+SIZE PNAME op 767 768matrixBorder(x,y1,y2,d,leftOrRight) == 769 y1 = y2 => 770 c := 771 leftOrRight = 'left => specialChar('lbrk) 772 specialChar('rbrk) 773 APP(c,x,y1,d) 774 for y in y1..y2 repeat 775 c := 776 y = y1 => 777 leftOrRight = 'left => specialChar('llc) 778 specialChar('lrc) 779 y = y2 => 780 leftOrRight = 'left => specialChar('ulc) 781 specialChar('urc) 782 specialChar('vbar) 783 d := APP(c,x,y,d) 784 d 785 786widthSC u == 10000 787 788--% The over-large matrix package 789 790maprinSpecial(x,$MARGIN,$LINELENGTH) == maprin0 x 791 792maprin x == 793 CATCH('output,maprin0 x) 794 nil 795 796maprin0 x == 797 $MatrixCount:local :=0 798 $MatrixList:local :=nil 799 maprinChk x 800 if $MatrixList then maprinRows $MatrixList 801 802maprinChk x == 803 null $MatrixList => maPrin x 804 ATOM x and (u:= assoc(x,$MatrixList)) => 805 $MatrixList := delete(u,$MatrixList) 806 maPrin deMatrix CDR u 807 x is ["=",arg,y] => --case for tracing with )math and printing matrices 808 u:= assoc(y,$MatrixList) => 809 -- we don't want to print matrix1 = matrix2 ... 810 $MatrixList := delete(u,$MatrixList) 811 maPrin ["=",arg, deMatrix CDR u] 812 maPrin x 813 x is ['EQUATNUM,n,y] => 814 $MatrixList is [[name,:value]] and y=name => 815 $MatrixList:=[] -- we are pulling this one off 816 maPrin ['EQUATNUM,n, deMatrix value] 817 IDENTP y => --------this part is never called 818 -- Not true: JHD 28/2/93 819 -- m:=[[1,2,3],[4,5,6],[7,8,9]] 820 -- mm:=[[m,1,0],[0,m,1],[0,1,m]] 821 -- and try to print mm**5 822 u := assoc(y,$MatrixList) 823 $MatrixList := delete(u,$MatrixList) 824 maPrin ['EQUATNUM,n,rest u] 825 if not $collectOutput then TERPRI(get_algebra_stream()) 826 maPrin x 827 maPrin x 828 829maprinRows matrixList == 830 if not $collectOutput then TERPRI(get_algebra_stream()) 831 y:=NREVERSE matrixList 832 --Makes the matrices come out in order, since CONSed on backwards 833 matrixList:=nil 834 firstName := first first y 835 for [name,:m] in y for n in 0.. repeat 836 if not $collectOutput then TERPRI(get_algebra_stream()) 837 andWhere := (name = firstName => '"where "; '"and ") 838 line := STRCONC(andWhere, PNAME name) 839 maprinChk ["=",line,m] 840 841deMatrix m == 842 ['BRACKET,['AGGLST, 843 :[['BRACKET,['AGGLST,:rest row]] for row in CDDR m]]] 844 845LargeMatrixp(u,width, dist) == 846 -- sees if there is a matrix wider than 'width' in the next 'dist' 847 -- part of u, a sized charybdis structure. 848 -- NIL if not, first such matrix if there is one 849 ATOM u => nil 850 CDAR u <= width => nil 851 --CDAR is the width of a charybdis structure 852 op:=CAAR u 853 op = 'MATRIX => true 854 --We already know the structure is more than 'width' wide 855 MEMQ(op,'(LET SEGMENT _- CONCAT CONCATB PAREN BRACKET BRACE)) => 856 --Each of these prints the arguments in a width 3 smaller 857 dist:=dist-3 858 width:=width-3 859 ans:= 860 for v in rest u repeat 861 (ans:=LargeMatrixp(v,width,dist)) => return ans 862 dist:=dist - WIDTH v 863 dist<0 => return nil 864 ans 865 --Relying that falling out of a loop gives nil 866 MEMQ(op,'(_+ _* )) => 867 --Each of these prints the first argument in a width 3 smaller 868 (ans:=LargeMatrixp(CADR u,width-3,dist)) => ans 869 n:=3+WIDTH CADR u 870 dist:=dist-n 871 ans:= 872 for v in CDDR u repeat 873 (ans:=LargeMatrixp(v,width,dist)) => return ans 874 dist:=dist - WIDTH v 875 dist<0 => return nil 876 ans 877 --Relying that falling out of a loop gives nil 878 ans:= 879 for v in rest u repeat 880 (ans:=LargeMatrixp(v,width,dist)) => return ans 881 dist:=dist - WIDTH v 882 dist<0 => return nil 883 ans 884 --Relying that falling out of a loop gives nil 885 886PushMatrix m == 887 --Adds the matrix to the look-aside list, and returns a name for it 888 name:= 889 for v in $MatrixList repeat 890 EQUAL(m, CDR v) => return first v 891 name => name 892 name := INTERNL1('"matrix", STRINGIMAGE($MatrixCount := $MatrixCount + 1)) 893 $MatrixList:=[[name,:m],:$MatrixList] 894 name 895 896quoteApp([.,a],x,y,d) == APP(a,x+1,y,appChar(PNAME "'",x,y,d)) 897 898quoteSub [.,a] == subspan a 899 900quoteSuper [.,a] == superspan a 901 902quoteWidth [.,a] == 1 + WIDTH a 903 904SubstWhileDesizing(u) == 905 --Replaces all occurrences of matrix by name in u 906 --Taking out any outdated size information as it goes 907 ATOM u => u 908 [[op,:n],:l]:=u 909 op = 'MATRIX => 910 l' := SubstWhileDesizingList(rest l) 911 u := 912 [op,nil,:l'] 913 PushMatrix u 914 l':=SubstWhileDesizingList(l) 915 ATOM op => [op,:l'] 916 [SubstWhileDesizing(op),:l'] 917 918 919SubstWhileDesizingList(u) == 920 [SubstWhileDesizing(i) for i in u] 921 922 923--% Printing of Sigmas , Pis and Intsigns 924 925sigmaSub u == 926 --The depth function for sigmas with lower limit only 927 MAX(1 + height CADR u, subspan CADDR u) 928 929sigmaSup u == 930 --The height function for sigmas with lower limit only 931 MAX(1, superspan CADDR u) 932 933sigmaApp(u,x,y,d) == 934 u is [.,bot,arg] or THROW('outputFailure,'outputFailure) 935 bigopAppAux(bot,nil,arg,x,y,d,'sigma) 936 937sigma2App(u,x,y,d) == 938 [.,bot,top,arg]:=u 939 bigopAppAux(bot,top,arg,x,y,d,'sigma) 940 941bigopWidth(bot,top,arg,kind) == 942 kindWidth := (kind = 'pi => 5; 3) 943 MAX(kindWidth,WIDTH bot,(top => WIDTH top; 0)) + 2 + WIDTH arg 944 945bigopAppAux(bot,top,arg,x,y,d,kind) == 946 botWidth := (bot => WIDTH bot; 0) 947 topWidth := WIDTH top 948 opWidth := 949 kind = 'pi => 5 950 3 951 maxWidth := MAX(opWidth,botWidth,topWidth) 952 xCenter := QUOTIENT(maxWidth - 1, 2) + x 953 d:=APP(arg,x+2+maxWidth,y,d) 954 d:= 955 atom bot and SIZE atom2String bot = 1 => APP(bot,xCenter,y-2,d) 956 APP(bot, x + QUOTIENT(maxWidth - botWidth, 2), y-2-superspan bot, d) 957 if top then 958 d:= 959 atom top and SIZE atom2String top = 1 => APP(top,xCenter,y+2,d) 960 APP(top, x + QUOTIENT(maxWidth - topWidth, 2), y+2+subspan top, d) 961 delta := (kind = 'pi => 2; 1) 962 opCode := 963 kind = 'sigma => 964 [['(0 . 0),:'">"],_ 965 ['(0 . 1),:specialChar('hbar)],_ 966 ['(0 . -1),:specialChar('hbar)],_ 967 ['(1 . 1),:specialChar('hbar)],_ 968 ['(1 . -1),:specialChar('hbar)],_ 969 ['(2 . 1),:specialChar('urc )],_ 970 ['(2 . -1),:specialChar('lrc )]] 971 kind = 'pi => 972 [['(0 . 1),:specialChar('ulc )],_ 973 ['(1 . 0),:specialChar('vbar)],_ 974 ['(1 . 1),:specialChar('ttee)],_ 975 ['(1 . -1),:specialChar('vbar)],_ 976 ['(2 . 1),:specialChar('hbar)],_ 977 ['(3 . 0),:specialChar('vbar)],_ 978 ['(3 . 1),:specialChar('ttee)],_ 979 ['(3 . -1),:specialChar('vbar)],_ 980 ['(4 . 1),:specialChar('urc )]] 981 THROW('outputFailure,'outputFailure) 982 xLate(opCode,xCenter - delta,y,d) 983 984sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma) 985sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma) 986 987sigma2Sub u == 988 --The depth function for sigmas with 2 limits 989 MAX(1 + height CADR u, subspan CADDDR u) 990 991sigma2Sup u == 992 --The depth function for sigmas with 2 limits 993 MAX(1 + height CADDR u, superspan CADDDR u) 994 995piSub u == 996 --The depth function for pi's (products) 997 MAX(1 + height CADR u, subspan CADDR u) 998 999piSup u == 1000 --The height function for pi's (products) 1001 MAX(1, superspan CADDR u) 1002 1003piApp(u,x,y,d) == 1004 u is [.,bot,arg] or THROW('outputFailure,'outputFailure) 1005 bigopAppAux(bot,nil,arg,x,y,d,'pi) 1006 1007piWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'pi) 1008pi2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'pi) 1009 1010pi2Sub u == 1011 --The depth function for pi's with 2 limits 1012 MAX(1 + height CADR u, subspan CADDDR u) 1013 1014pi2Sup u == 1015 --The depth function for pi's with 2 limits 1016 MAX(1 + height CADDR u, superspan CADDDR u) 1017 1018pi2App(u,x,y,d) == 1019 [.,bot,top,arg]:=u 1020 bigopAppAux(bot,top,arg,x,y,d,'pi) 1021 1022overlabelSuper [.,a,b] == 1 + height a + superspan b 1023 1024overlabelWidth [.,a,b] == WIDTH b 1025 1026overlabelApp([.,a,b], x, y, d) == 1027 d := APP(b, x, y, d) -- the part that is under the label 1028 -- if b is empty, we set the width to 1 to prevent overflow 1029 wb := MAX(WIDTH b, 1) 1030 endPoint := x + wb - 1 1031 middle := QUOTIENT(x + endPoint,2) 1032 h := y + superspan b + 1 1033 d := APP(a,middle,h + 1,d) 1034 apphor(x, endPoint, y+superspan b+1,d,"|") 1035 1036overbarSuper u == 1 + superspan u.1 1037 1038overbarWidth u == WIDTH u.1 1039 1040overbarApp(u,x,y,d) == 1041 d := APP(u.1, x, y, d) -- the part that is under the bar 1042 apphor(x,x+WIDTH u.1-1,y+superspan u.1+1,d,UNDERBAR) 1043 1044intSub u == 1045 MAX(1 + height u.1, subspan u.3) 1046 1047intSup u == 1048 MAX(1 + height u.2, superspan u.3) 1049 1050intApp(u,x,y,d) == 1051 [.,bot,top,arg]:=u 1052 d:=APP(arg,x+4+MAX(-4 + WIDTH bot, WIDTH top),y,d) 1053 d:=APP(bot,x,y-2-superspan bot,d) 1054 d:=APP(top,x+3,y+2+subspan top,d) 1055 xLate( [['(0 . -1),:specialChar('llc) ],_ 1056 ['(1 . -1),:specialChar('lrc) ],_ 1057 ['(1 . 0),:specialChar('vbar)],_ 1058 ['(1 . 1),:specialChar('ulc) ],_ 1059 ['(2 . 1),:specialChar('urc) ]], x,y,d) 1060 1061intWidth u == 1062 # u < 4 => THROW('outputFailure,'outputFailure) 1063 MAX(-4 + WIDTH u.1, WIDTH u.2) + WIDTH u.3 + 5 1064 1065xLate(l,x,y,d) == 1066 for [[a,:b],:c] in l repeat 1067 d:= appChar(c,x+a,y+b,d) 1068 d 1069 1070concatTrouble(u, d, start, lineLength, addBlankIfTrue) == 1071 [x,:l] := splitConcat(u, lineLength, true, addBlankIfTrue) 1072 null l => 1073 sayALGEBRA ['%l,'%b,'" Too wide to Print",'%d] 1074 THROW('output,nil) 1075 charybdis(fixUp(x, addBlankIfTrue), start, lineLength) 1076 for y in l repeat 1077 if d then prnd(start,d) 1078 y := fixUp(y, addBlankIfTrue) 1079 if lineLength > 2 then 1080 charybdis(y, start + 2, lineLength - 2) -- JHD needs this to avoid lunacy 1081 else charybdis(y, start, 1) -- JHD needs this to avoid lunacy 1082 BLANK 1083 where 1084 fixUp(x, addBlankIfTrue) == 1085 rest x => 1086 addBlankIfTrue => ['CONCATB,:x] 1087 ["CONCAT",:x] 1088 first x 1089 1090splitConcat(list, maxWidth, firstTimeIfTrue, addBlankIfTrue) == 1091 null list => nil 1092 -- split list l into a list of n lists, each of which 1093 -- has width < maxWidth 1094 totalWidth:= 0 1095 oneOrZero := (addBlankIfTrue => 1; 0) 1096 l := list 1097 maxW:= (firstTimeIfTrue => maxWidth; maxWidth-2) 1098 maxW < 1 => [[x] for x in l] -- JHD 22.8.95, otherwise things can break 1099 for x in tails l 1100 while (width := oneOrZero + WIDTH first x + totalWidth) < maxW repeat 1101 l:= x 1102 totalWidth:= width 1103 x:= rest l 1104 rplac(rest l, nil) 1105 [list, :splitConcat(x, maxWidth, nil, addBlankIfTrue)] 1106 1107spadPrint(x,m) == 1108 m = $NoValueMode => x 1109 if not $collectOutput then TERPRI(get_algebra_stream()) 1110 output(x,m) 1111 if not $collectOutput then TERPRI(get_algebra_stream()) 1112 1113fortranFormat expr == 1114 ff := '(FortranFormat) 1115 formatFn := 1116 getFunctionFromDomain("convert", ff, [$OutputForm, $Integer]) 1117 displayFn := getFunctionFromDomain("display", ff, [ff]) 1118 SPADCALL(SPADCALL(expr, $IOindex, formatFn), displayFn) 1119 if not $collectOutput then TERPRI(get_fortran_stream()) 1120 FORCE_-OUTPUT(get_fortran_stream()) 1121 1122 1123texFormat expr == 1124 ioHook("startTeXOutput") 1125 tf := '(TexFormat) 1126 formatFn := 1127 getFunctionFromDomain("convert",tf,[$OutputForm,$Integer]) 1128 displayFn := getFunctionFromDomain("display",tf,[tf]) 1129 SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn) 1130 TERPRI(get_tex_stream()) 1131 FORCE_-OUTPUT(get_tex_stream()) 1132 ioHook("endOfTeXOutput") 1133 NIL 1134 1135texFormat1 expr == 1136 tf := '(TexFormat) 1137 formatFn := getFunctionFromDomain("coerce",tf, [$OutputForm]) 1138 displayFn := getFunctionFromDomain("display",tf,[tf]) 1139 SPADCALL(SPADCALL(expr,formatFn),displayFn) 1140 TERPRI(get_tex_stream()) 1141 FORCE_-OUTPUT(get_tex_stream()) 1142 NIL 1143 1144mathmlFormat expr == 1145 mml := '(MathMLFormat) 1146 mmlrep := '(String) 1147 formatFn := getFunctionFromDomain("coerce",mml,[$OutputForm]) 1148 displayFn := getFunctionFromDomain("display",mml,[mmlrep]) 1149 SPADCALL(SPADCALL(expr,formatFn),displayFn) 1150 TERPRI(get_mathml_stream()) 1151 FORCE_-OUTPUT(get_mathml_stream()) 1152 NIL 1153 1154texmacsFormat expr == 1155 ioHook("startTeXmacsOutput") 1156 mml := '(TexmacsFormat) 1157 mmlrep := '(String) 1158 formatFn := getFunctionFromDomain("coerce",mml,[$OutputForm]) 1159 displayFn := getFunctionFromDomain("display",mml,[mmlrep]) 1160 SPADCALL(SPADCALL(expr,formatFn),displayFn) 1161 TERPRI(get_texmacs_stream()) 1162 FORCE_-OUTPUT(get_texmacs_stream()) 1163 ioHook("endOfTeXmacsOutput") 1164 NIL 1165 1166htmlFormat expr == 1167 htf := '(HTMLFormat) 1168 htrep := '(String) 1169 formatFn := getFunctionFromDomain("coerce", htf, [$OutputForm]) 1170 displayFn := getFunctionFromDomain("display", htf, [htrep]) 1171 SPADCALL(SPADCALL(expr,formatFn),displayFn) 1172 TERPRI(get_html_stream()) 1173 FORCE_-OUTPUT(get_html_stream()) 1174 NIL 1175 1176formattedFormat expr == 1177 ty := '(FormattedOutput) 1178 formatFn := getFunctionFromDomain("convert", ty, [$OutputForm, $Integer]) 1179 displayFn := getFunctionFromDomain("display", ty , [ty]) 1180 SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn) 1181 say_new_line(get_formatted_stream()) 1182 FORCE_-OUTPUT(get_formatted_stream()) 1183 NIL 1184 1185output(expr,domain) == 1186 $resolve_level : local := 0 1187 if isWrapped expr then expr := unwrap expr 1188 isMapExpr expr and not(domain is ["FunctionCalled", .]) => BREAK() 1189 categoryForm? domain or domain = ["Mode"] => 1190 if $algebraFormat then 1191 mathprintWithNumber outputDomainConstructor expr 1192 if $texFormat then 1193 texFormat outputDomainConstructor expr 1194 T := coerceInteractive(objNewWrap(expr,domain),$OutputForm) => 1195 x := objValUnwrap T 1196 if $fortranFormat then fortranFormat x 1197 if $algebraFormat then 1198 mathprintWithNumber x 1199 if $texFormat then texFormat x 1200 if $mathmlFormat then mathmlFormat x 1201 if $texmacsFormat then texmacsFormat x 1202 if $htmlFormat then htmlFormat x 1203 if $formattedFormat then formattedFormat x 1204 (FUNCTIONP(opOf domain)) and (not(SYMBOLP(opOf domain))) and 1205 (printfun := compiledLookup("<<",'(TextWriter TextWriter $), evalDomain domain)) 1206 and (textwrit := compiledLookup("print", '($), TextWriter())) => 1207 sayMSGNT [:bright '"Aldor",'"output: "] 1208 SPADCALL(SPADCALL textwrit, expr, printfun) 1209 sayMSGNT '%l 1210 1211 -- big hack for tuples for new compiler 1212 domain is ['Tuple, S] => output(asTupleAsList expr, ['List, S]) 1213 1214 sayALGEBRA [:bright '"LISP",'"output:",'%l,expr or '"NIL"] 1215 1216outputNumber(start,linelength,num) == 1217 if start > 1 then blnks := fillerSpaces(start-1,'" ") 1218 else blnks := '"" 1219 under:='"__" 1220 firsttime:=(linelength>3) 1221 if linelength>2 then 1222 linelength:=linelength-1 1223 while SIZE(num) > linelength repeat 1224 if $collectOutput then 1225 $outputLines := [CONCAT(blnks, SUBSTRING(num,0,linelength),under), 1226 :$outputLines] 1227 else 1228 sayALGEBRA [blnks, 1229 SUBSTRING(num,0,linelength),under] 1230 num := SUBSTRING(num,linelength,NIL) 1231 if firsttime then 1232 blnks:=CONCAT(blnks,'" ") 1233 linelength:=linelength-1 1234 firsttime:=NIL 1235 if $collectOutput then 1236 $outputLines := [CONCAT(blnks, num), :$outputLines] 1237 else 1238 sayALGEBRA [blnks, num] 1239 1240outputString(start,linelength,str) == 1241 if start > 1 then blnks := fillerSpaces(start-1,'" ") 1242 else blnks := '"" 1243 while SIZE(str) > linelength repeat 1244 if $collectOutput then 1245 $outputLines := [CONCAT(blnks, SUBSTRING(str,0,linelength)), 1246 :$outputLines] 1247 else 1248 sayALGEBRA [blnks, SUBSTRING(str,0,linelength)] 1249 str := SUBSTRING(str,linelength,NIL) 1250 if $collectOutput then 1251 $outputLines := [CONCAT(blnks, str), :$outputLines] 1252 else 1253 sayALGEBRA [blnks, str] 1254 1255outputDomainConstructor form == 1256 if VECTORP form then form := devaluate form 1257 atom (u:= prefix2String form) => u 1258 concatenateStringList([object2String(x) for x in u]) 1259 1260outputOp x == 1261 x is [op,:args] and (GETL(op,"LED") or GETL(op,"NUD")) => 1262 n:= 1263 GETL(op,"NARY") => 2 1264 #args 1265 newop:= INTERN STRCONC("*",STRINGIMAGE n,PNAME op) 1266 [newop,:[outputOp y for y in args]] 1267 x 1268 1269charybdis(u,start,linelength) == 1270 EQ(keyp u,'EQUATNUM) and not (CDDR u) => 1271 charybdis(['PAREN,u.1],start,linelength) 1272 charyTop(u,start,linelength) 1273 1274charyTop(u,start,linelength) == 1275 linelength < 1 => 1276 sayALGEBRA ['%l,'%b,'" Too wide to Print",'%d] 1277 THROW('output,nil) 1278 u is ['SC,:l] or u is [['SC,:.],:l] => 1279 for a in l repeat charyTop(a,start,linelength) 1280 u is [['CONCATB,:.],:m,[['SC,:.],:l]] => 1281 charyTop(['CONCATB,:m],start,linelength) 1282 charyTop(['SC,:l],start+2,linelength-2) 1283 u is ['CENTER,a] => 1284 b := charyTopWidth a 1285 (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength) 1286 charyTop(b, QUOTIENT(linelength-start-w, 2), linelength) 1287 v := charyTopWidth u 1288 EQ(keyp u,'ELSE) => charyElse(u,v,start,linelength) 1289 WIDTH(v) > linelength => charyTrouble(u,v,start,linelength) 1290 d := APP(v,start,0,nil) 1291 n := superspan v 1292 m := - subspan v 1293 -- FIXME: should we collect output here? 1294 until n < m repeat 1295 scylla(n,d) 1296 n := n - 1 1297 1298charyTopWidth u == 1299 atom u => u 1300 atom first u => putWidth u 1301 NUMBERP CDAR u => u 1302 putWidth u 1303 1304charyTrouble(u,v,start,linelength) == 1305 LargeMatrixp(u,linelength,2*linelength) => 1306 u := SubstWhileDesizing(u) 1307 maprinChk u 1308 charyTrouble1(u,v,start,linelength) 1309 1310charyTrouble1(u,v,start,linelength) == 1311 NUMBERP u => outputNumber(start,linelength,atom2String u) 1312 atom u => outputString(start,linelength,atom2String u) 1313 EQ(x:= keyp u,'_-) => charyMinus(u,v,start,linelength) 1314 MEMQ(x,'(_+ _* AGGLST)) => charySplit(u,v,start,linelength) 1315 EQ(x,'EQUATNUM) => charyEquatnum(u,v,start,linelength) 1316 d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) 1317 x = 'OVER => 1318 charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) 1319 EQ(3,LENGTH u) and GETL(x,'Led) => 1320 d:= PNAME first GETL(x,'Led) 1321 charyBinary(d,u,v,start,linelength) 1322 EQ(x,'CONCAT) => 1323 concatTrouble(rest v,d,start,linelength,nil) 1324 EQ(x,'CONCATB) => 1325 (rest v) is [loop, 'repeat, body] => 1326 charyTop(['CONCATB,loop,'repeat],start,linelength) 1327 charyTop(body,start+2,linelength-2) 1328 (rest v) is [wu, loop, 'repeat, body] and 1329 (keyp wu) is ['CONCATB,wu',.] and wu' in '(while until) => 1330 charyTop(['CONCATB,wu,loop,'repeat],start,linelength) 1331 charyTop(body,start+2,linelength-2) 1332 concatTrouble(rest v,d,start,linelength,true) 1333 GETL(x,'INFIXOP) => charySplit(u,v,start,linelength) 1334 EQ(x,'PAREN) and 1335 (EQ(keyp u.1,'AGGLST) and (v:= ",") or EQ(keyp u.1,'AGGSET) and 1336 (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)") 1337 EQ(x,'PAREN) and EQ(keyp u.1,'CONCATB) => 1338 bracketagglist(rest u.1,start,linelength," ","_(","_)") 1339 EQ(x,'BRACKET) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => 1340 bracketagglist(rest u.1,start,linelength,v, 1341 specialChar 'lbrk, specialChar 'rbrk) 1342 EQ(x,'BRACE) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => 1343 bracketagglist(rest u.1,start,linelength,v, 1344 specialChar 'lbrc, specialChar 'rbrc) 1345 EQ(x,'EXT) => longext(u,start,linelength) 1346 EQ(x,'MATRIX) => BREAK() 1347 EQ(x,'ELSE) => charyElse(u,v,start,linelength) 1348 EQ(x,'SC) => charySemiColon(u,v,start,linelength) 1349 charybdis(x,start,linelength) 1350 if rest u then charybdis(['ELSE,:rest u],start,linelength) 1351 1352charySemiColon(u,v,start,linelength) == 1353 for a in rest u repeat 1354 charyTop(a,start,linelength) 1355 nil 1356 1357charyMinus(u,v,start,linelength) == 1358 charybdis('"-",start,linelength) 1359 charybdis(v.1,start+3,linelength-3) 1360 1361charyBinary(d,u,v,start,linelength) == 1362 d in '(" := " "= ") => 1363 charybdis(['CONCATB,v.1,d],start,linelength) 1364 charybdis(v.2,start+2,linelength-2) 1365 charybdis(v.1,start+2,linelength-2) 1366 if d then prnd(start,d) 1367 charybdis(v.2,start+2,linelength-2) 1368 1369charyEquatnum(u,v,start,linelength) == 1370 charybdis(['PAREN,u.1],start,linelength) 1371 charybdis(u.2,start,linelength) 1372 1373charySplit(u,v,start,linelength) == 1374 v:= [first v.0,:rest v] 1375 m:= rest v 1376 WIDTH v.1 > linelength-2 => 1377 charybdis(v.1,start+2,linelength-2) 1378 not (CDDR v) => '" " 1379 dm:= CDDR v 1380 ddm:= rest dm 1381 split2(u,dm,ddm,start,linelength) 1382 for i in 0.. repeat 1383 dm := rest m 1384 ddm := rest dm 1385 RPLACD(dm,nil) 1386 WIDTH v > linelength - 2 => return nil 1387 rplac(first v, first v.0) 1388 RPLACD(dm,ddm) 1389 m := rest m 1390 rplac(first v, first v.0) 1391 RPLACD(m,nil) 1392 charybdis(v,start + 2,linelength - 2) 1393 split2(u,dm,ddm,start,linelength) 1394 1395split2(u,dm,ddm,start,linelength) == 1396 prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; '",")) 1397 RPLACD(dm,ddm) 1398 m:= WIDTH [keyp u,:dm]<linelength-2 1399 charybdis([keyp u,:dm],(m => start+2; start),(m => linelength-2; linelength)) 1400 1401charyElse(u,v,start,linelength) == 1402 charybdis(v.1,start+3,linelength-3) 1403 not (CDDR u) => '" " 1404 prnd(start,'",") 1405 charybdis(['ELSE,:CDDR v],start,linelength) 1406 1407scylla(n,v) == 1408 y := LASSOC(n,v) 1409 null y => nil 1410 if STRINGP(y) then y := DROPTRAILINGBLANKS COPY y 1411 if $collectOutput then 1412 $outputLines := [y, :$outputLines] 1413 else 1414 PRINTEXP(y, get_algebra_stream()) 1415 TERPRI(get_algebra_stream()) 1416 nil 1417 1418keyp(u) == 1419 atom u => nil 1420 atom first u => first u 1421 CAAR u 1422 1423absym x == 1424 (NUMBERP x) and (MINUSP x) => -x 1425 not (atom x) and (keyp(x) = '_-) => CADR x 1426 x 1427 1428agg(n,u) == 1429 (n = 1) => CADR u 1430 agg(n - 1, rest u) 1431 1432aggwidth u == 1433 null u => 0 1434 null rest u => WIDTH first u 1435 1 + (WIDTH first u) + (aggwidth rest u) 1436 1437argsapp(u,x,y,d) == appargs(rest u,x,y,d) 1438 1439subspan u == 1440 atom u => 0 1441 NUMBERP rest u => subspan first u 1442 (not atom first u and_ 1443 atom CAAR u and_ 1444 not NUMBERP CAAR u and_ 1445 GETL(CAAR u, 'SUBSPAN) ) => 1446 APPLY(GETL(CAAR u, 'SUBSPAN), LIST u) 1447 MAX(subspan first u, subspan rest u) 1448 1449agggsub u == subspan rest u 1450 1451superspan u == 1452 atom u => 0 1453 NUMBERP rest u => superspan first u 1454 (not atom first u and_ 1455 atom CAAR u and_ 1456 not NUMBERP CAAR u and_ 1457 GETL(CAAR u, 'SUPERSPAN) ) => 1458 APPLY(GETL(CAAR u, 'SUPERSPAN), LIST u) 1459 MAX(superspan first u, superspan rest u) 1460 1461agggsuper u == superspan rest u 1462 1463agggwidth u == aggwidth rest u 1464 1465appagg(u,x,y,d) == agg_app(u, x, y, d, '",", 1) 1466 1467appargs(u, x, y, d) == agg_app(u, x, y, d, '";", 1) 1468 1469apprpar(x, y, y1, y2, d) == 1470 (not ($tallPar) or (y2 - y1 < 2)) => APP('")", x, y, d) 1471 true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) 1472 1473apprpar1(x, y, y1, y2, d) == 1474 (y1 = y2) => APP('")", x, y2, d) 1475 true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) 1476 1477applpar(x, y, y1, y2, d) == 1478 (not ($tallPar) or (y2 - y1 < 2)) => APP('"(", x, y, d) 1479 true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) 1480 1481applpar1(x, y, y1, y2, d) == 1482 (y1 = y2) => APP('"(", x, y2, d) 1483 true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) 1484 1485--The body of the function appelse assigns 6 local variables. 1486--It then finishes by calling apprpar. 1487 1488appelse(u,x,y,d) == 1489 w := WIDTH CAAR u 1490 b := y - subspan rest u 1491 p := y + superspan rest u 1492 temparg1 := APP(keyp u, x, y, d) 1493 temparg2 := applpar(x + w, y, b, p, temparg1) 1494 temparg3 := appagg(rest u, x + 1 + w, y, temparg2) 1495 apprpar(x + 1 + w + aggwidth rest u, y, b, p, temparg3) 1496 1497appext(u,x,y,d) == 1498 xptr := x 1499 yptr := y - (subspan CADR u + superspan agg(3,u) + 1) 1500 d := APP(CADR u,x,y,d) 1501 d := APP(agg(2,u),xptr,yptr,d) 1502 xptr := xptr + WIDTH agg(2,u) 1503 d := APP('"=", xptr, yptr,d) 1504 d := APP(agg(3,u), 1 + xptr, yptr, d) 1505 yptr := y + 1 + superspan CADR u + SUBSPAD agg(4,u) 1506 d := APP(agg(4,u), x, yptr, d) 1507 temp := 1 + WIDTH agg(2,u) + WIDTH agg(3,u) 1508 n := MAX(WIDTH CADR u, WIDTH agg(4,u), temp) 1509 if EQCAR(first(z := agg(5,u)), 'EXT) and 1510 (EQ(n,3) or (n > 3 and not (atom z)) ) then 1511 n := 1 + n 1512 d := APP(z, x + n, y, d) 1513 1514apphor(x1,x2,y,d,char) == 1515 temp := (x1 = x2 => d; apphor(x1, x2 - 1, y, d,char)) 1516 APP(char, x2, y, temp) 1517 1518syminusp x == 1519 NUMBERP x => MINUSP x 1520 not (atom x) and EQ(keyp x,'_-) 1521 1522appsum(u, x, y, d) == 1523 null u => d 1524 ac := absym first u 1525 sc := 1526 syminusp first u => '"-" 1527 true => '"+" 1528 dp := member(keyp ac, '(_+ _-)) 1529 tempx := x + WIDTH ac + (dp => 5; true => 3) 1530 tempdblock := 1531 temparg1 := APP(sc, x + 1, y, d) 1532 dp => 1533 bot := y - subspan ac 1534 top := y + superspan ac 1535 temparg2 := applpar(x + 3, y, bot, top, temparg1) 1536 temparg3 := APP(ac, x + 4, y, temparg2) 1537 apprpar(x + 4 + WIDTH ac, y, bot, top, temparg3) 1538 true => APP(ac, x + 3, y, temparg1) 1539 appsum(rest u, tempx, y, tempdblock) 1540 1541appneg(u, x, y, d) == 1542 appsum(LIST u, x - 1, y, d) 1543 1544appparu(u, x, y, d) == 1545 bot := y - subspan u 1546 top := y + superspan u 1547 temparg1 := applpar(x, y, bot, top, d) 1548 temparg2 := APP(u, x + 1, y, temparg1) 1549 apprpar(x + 1 + WIDTH u, y, bot, top, temparg2) 1550 1551appparu1(u, x, y, d) == 1552 appparu(CADR u, x, y, d) 1553 1554appsc(u, x, y, d) == 1555 appagg1(rest u, x, y, d, '";") 1556 1557appsetq(u, x, y, d) == 1558 w := WIDTH first u 1559 temparg1 := APP(CADR u, x, y, d) 1560 temparg2 := APP('":", x + w, y, temparg1) 1561 APP(CADR rest u, x + 2 + w, y, temparg2) 1562 1563appsub(u, x, y, d) == 1564 temparg1 := x + WIDTH CADR u 1565 temparg2 := y - 1 - superspan CDDR u 1566 temparg3 := APP(CADR u, x, y, d) 1567 appagg(CDDR u, temparg1, temparg2, temparg3) 1568 1569eq0(u) == 0 1570 1571height(u) == 1572 superspan(u) + 1 + subspan(u) 1573 1574extsub(u) == 1575 MAX(subspan agg(5, u), height(agg(3, u)), subspan CADR u ) 1576 1577extsuper(u) == 1578 MAX(superspan CADR u + height agg(4, u), superspan agg(5, u) ) 1579 1580extwidth(u) == 1581 n := MAX(WIDTH CADR u, 1582 WIDTH agg(4, u), 1583 1 + WIDTH agg(2, u) + WIDTH agg(3, u) ) 1584 nil or 1585 (EQCAR(first(z := agg(5, u)), 'EXT) and _ 1586 (EQ(n, 3) or ((n > 3) and null atom z) ) => 1587 n := 1 + n) 1588 true => n + WIDTH agg(5, u) 1589 1590appfrac(u, x, y, d) == 1591 -- Added "1+" to both QUOTIENT statements so that when exact centering is 1592 -- not possible, expressions are offset to the right rather than left. 1593 -- MCD 16-8-95 1594 w := WIDTH u 1595 tempx := x + QUOTIENT(1+w - WIDTH CADR rest u, 2) 1596 tempy := y - superspan CADR rest u - 1 1597 temparg3 := APP(CADR rest u, tempx, tempy, d) 1598 temparg4 := apphor(x, x + w - 1, y, temparg3,specialChar('hbar)) 1599 APP(CADR u, 1600 x + QUOTIENT(1+w - WIDTH CADR u, 2), 1601 y + 1 + subspan CADR u, 1602 temparg4) 1603 1604fracsub(u) == height CADR rest u 1605 1606fracsuper(u) == height CADR u 1607 1608fracwidth(u) == 1609 numw := WIDTH (num := CADR u) 1610 denw := WIDTH (den := CADDR u) 1611 if num is [[op,:.],:.] and op = 'OVER then numw := numw + 2 1612 if den is [[op,:.],:.] and op = 'OVER then denw := denw + 2 1613 MAX(numw,denw) 1614 1615slashSub u == 1616 MAX(1,subspan(CADR u),subspan(CADR rest u)) 1617 1618slashSuper u == 1619 MAX(1,superspan(CADR u),superspan(CADR rest u)) 1620 1621slashApp(u, x, y, d) == 1622 -- to print things as a/b as opposed to 1623 -- a 1624 -- - 1625 -- b 1626 temparg1 := APP(CADR u, x, y, d) 1627 temparg2 := APP('"/", x + WIDTH CADR u, y, temparg1) 1628 APP(CADR rest u, 1629 x + 1 + WIDTH CADR u, y, temparg2) 1630 1631slashWidth(u) == 1632 -- to print things as a/b as opposed to 1633 -- a 1634 -- - 1635 -- b 1636 1 + WIDTH CADR u + WIDTH CADR rest u 1637 1638longext(u, i, n) == 1639 x := REVERSE u 1640 y := first x 1641 u := remWidth(REVERSEWOC(CONS('" ", rest x))) 1642 charybdis(u, i, n) 1643 if not $collectOutput then TERPRI(get_algebra_stream()) 1644 charybdis(CONS('ELSE, LIST y), i, n) 1645 '" " 1646 1647appvertline(char, x, yl, yu, d) == 1648 yu < yl => d 1649 temparg := appvertline(char, x, yl, yu - 1, d) 1650 true => APP(char, x, yu, temparg) 1651 1652appHorizLine(xl, xu, y, d) == 1653 xu < xl => d 1654 temparg := appHorizLine(xl, xu - 1, y, d) 1655 true => APP(MATBORCH, xu, y, temparg) 1656 1657rootApp(u, x, y, d) == 1658 widB := WIDTH u.1 1659 supB := superspan u.1 1660 subB := subspan u.1 1661 if #u > 2 then 1662 widR := WIDTH u.2 1663 subR := subspan u.2 1664 d := APP(u.2, x, y - subB + 1 + subR, d) 1665 else 1666 widR := 1 1667 d := APP(u.1, x + widR + 1, y, d) 1668 d := apphor(x+widR+1, x+widR+widB, y+supB+1, d, specialChar('hbar)) 1669 d := appvertline(specialChar('vbar), x+widR, y - subB, y + supB, d) 1670 d := APP(specialChar('ulc), x+widR, y + supB+1, d) 1671 d := APP(specialChar('urc), x + widR + widB + 1, y + supB+1, d) 1672 d := APP(specialChar('bslash), x + widR - 1, y - subB, d) 1673 1674boxApp(u, x, y, d) == 1675 CDDR u => boxLApp(u, x, y, d) 1676 a := 1 + superspan u.1 1677 b := 1 + subspan u.1 1678 w := 2 + WIDTH u.1 1679 d := appvertline(specialChar('vbar), x,y - b + 1, y + a - 1, d) 1680 d := appvertline(specialChar('vbar), x + w + 1, y - b,y + a,d) 1681 d := apphor(x + 1, x + w, y - b, d, specialChar('hbar)) 1682 d := apphor(x + 1, x + w, y + a, d, specialChar('hbar)) 1683 d := APP(specialChar('ulc), x, y + a, d) 1684 d := APP(specialChar('urc), x + w + 1, y + a, d) 1685 d := APP(specialChar('llc), x, y - b, d) 1686 d := APP(specialChar('lrc), x + w + 1, y - b, d) 1687 d := APP(u.1, 2 + x, y, d) 1688 1689boxLApp(u, x, y, d) == 1690 la := superspan u.2 1691 lb := subspan u.2 1692 lw := 2 + WIDTH u.2 1693 lh := 2 + la + lb 1694 a := superspan u.1+1 1695 b := subspan u.1+1 1696 w := MAX(lw, 2 + WIDTH u.1) 1697 -- next line used to have h instead of lh 1698 top := y + a + lh 1699 d := appvertline(MATBORCH, x, y - b, top, d) 1700 d := appHorizLine(x + 1, x + w, top, d) 1701 d := APP(u.2, 2 + x, y + a + lb + 1, d) 1702 d := appHorizLine(x + 1, x + lw, y + a, d) 1703 nil or 1704 lw < w => d := appvertline(MATBORCH, x + lw + 1, y + a, top - 1, d) 1705 d := APP(u.1, 2 + x, y, d) 1706 d := appHorizLine(x + 1, x + w, y - b, d) 1707 d := appvertline(MATBORCH, x + w + 1, y - b, top, d) 1708 1709boxSub(x) == 1710 subspan x.1+1 1711 1712boxSuper(x) == 1713 null rest x => 0 1714 hl := 1715 null CDDR x => 0 1716 true => 2 + subspan x.2 + superspan x.2 1717 true => hl+1 + superspan x.1 1718 1719boxWidth(x) == 1720 null rest x => 0 1721 wl := 1722 null CDDR x => 0 1723 true => WIDTH x.2 1724 true => 4 + MAX(wl, WIDTH x.1) 1725 1726nothingWidth x == 1727 0 1728nothingSuper x == 1729 0 1730nothingSub x == 1731 0 1732nothingApp(u, x, y, d) == 1733 d 1734 1735zagApp(u, x, y, d) == 1736 w := WIDTH u 1737 denx := x + QUOTIENT(w - WIDTH CADR rest u, 2) 1738 deny := y - superspan CADR rest u - 1 1739 d := APP(CADR rest u, denx, deny, d) 1740 numx := x + QUOTIENT(w - WIDTH CADR u, 2) 1741 numy := y+1 + subspan CADR u 1742 d := APP(CADR u, numx, numy, d) 1743 a := 1 + zagSuper u 1744 b := 1 + zagSub u 1745 d := appvertline(specialChar('vbar), x, y - b, y - 1, d) 1746 d := appvertline(specialChar('vbar), x + w - 1, y + 1, y + a, d) 1747 d := apphor(x, x + w - 2, y, d, specialChar('hbar)) 1748 d := APP(specialChar('ulc), x, y, d) 1749 d := APP(specialChar('lrc), x + w - 1, y, d) 1750 1751zagSub(u) == 1752 height CADR rest u 1753 1754zagSuper(u) == 1755 height CADR u 1756 1757zagWidth(x) == 1758 #x = 1 => 0 1759 #x = 2 => 4 + WIDTH x.1 1760 4 + MAX(WIDTH x.1, WIDTH x.2) 1761 1762rootWidth(x) == 1763 #x <= 2 => 3 + WIDTH x.1 1764 2 + WIDTH x.1 + WIDTH x.2 1765 1766rootSub(x) == 1767 subspan x.1 1768 1769rootSuper(x) == 1770 normal := 1 + superspan x.1 1771 #x <= 2 => normal 1772 (radOver := height x.2 - height x.1) < 0 => normal 1773 normal + radOver 1774 1775appmat(u, x, y, d) == 1776 rows := CDDR u 1777 p := matSuper u 1778 q := matSub u 1779 d := matrixBorder(x, y - q, y + p, d, 'left) 1780 x := 1 + x 1781 yc := 1 + y + p 1782 w := CADR u 1783 wl := CDAR w 1784 subl := rest CADR w 1785 superl := rest CADR rest w 1786 repeat 1787 null rows => 1788 wu := MAX(0, WIDTH u - 2) 1789 return(matrixBorder(x + wu, y - q, y + p, d, 'right)) 1790 xc := x 1791 yc := yc - 1 - first superl 1792 w := wl 1793 row := CDAR rows 1794 repeat 1795 if flag = '"ON" then 1796 flag := '"OFF" 1797 return(nil) 1798 null row => 1799 repeat 1800 yc := yc - 1 - first subl 1801 subl := rest subl 1802 superl := rest superl 1803 rows := rest rows 1804 return(flag := '"ON"; nil) 1805 d := APP(first row, 1806 xc + QUOTIENT(first w - WIDTH first row, 2), 1807 yc, 1808 d) 1809 xc := xc + 2 + first w 1810 row := rest row 1811 w := rest w 1812 1813matSuper(x) == 1814 (x := x.1) => -1 + QUOTIENT(first x.1 + first x.2, 2) 1815 true => ERROR('MAT) 1816 1817matSub(x) == 1818 (x := x.1) => QUOTIENT(-1 + first x.1 + first x.2, 2) 1819 true => ERROR('MAT) 1820 1821matWidth(x) == 1822 y := CDDR x -- list of rows, each of form ((ROW . w) element element ...) 1823 numOfColumns := LENGTH CDAR y 1824 widthList := matLSum2 matWList(y, [0 for j in 1..numOfColumns]) 1825 --returns ["max width of entries in column i" for i in 1..numberOfRows] 1826 subspanList := matLSum matSubList y 1827 superspanList := matLSum matSuperList y 1828 rplac(x.1, [widthList, subspanList, superspanList]) 1829 CAAR x.1 1830 1831matLSum(x) == 1832 CONS(sumoverlist x + LENGTH x, x) 1833 1834matLSum2(x) == 1835 null x => [2] 1836 CONS(sumoverlist x + 2*(LENGTH x), x) 1837 1838matWList(x, y) == 1839 null x => y 1840 true => matWList(rest x, matWList1(CDAR x, y) ) 1841 1842matWList1(x, y) == 1843 null x => nil 1844 true => CONS(MAX(WIDTH first x, first y), matWList1(rest x, rest y) ) 1845 1846matSubList(x) == --computes the max/[subspan(e) for e in "row named x"] 1847 null x => nil 1848 true => CONS(matSubList1(CDAR x, 0), matSubList(rest x) ) 1849 1850matSubList1(x, y) == 1851 null x => y 1852 true => matSubList1(rest x, MAX(y, subspan first x) ) 1853 1854matSuperList(x) == --computes the max/[superspan(e) for e in "row named x"] 1855 null x => nil 1856 true => CONS(matSuperList1(CDAR x, 0), matSuperList(rest x) ) 1857 1858matSuperList1(x, y) == 1859 null x => y 1860 true => matSuperList1(rest x, MAX(y, superspan first x) ) 1861 1862minusWidth(u) == 1863 -1 + sumWidthA rest u 1864 1865bracketagglist(u, start, linelength, tchr, open, close) == 1866 u := CONS(LIST('CONCAT, open, first u), 1867 [LIST('CONCAT, '" ", y) for y in rest u] ) 1868 repeat 1869 s := 0 1870 for x in tails u repeat 1871 lastx := x 1872 ((s := s + WIDTH first x + 1) >= linelength) => return(s) 1873 null rest x => return(s := -1) 1874 nil or 1875 EQ(s, -1) => (nextu := nil) 1876 EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) ) 1877 true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil)) 1878 for x in tails u repeat 1879 RPLACA(x, LIST('CONCAT, first x, tchr)) 1880 if null nextu then RPLACA(CDDR last u, close) 1881 charybdis(ASSOCIATER('CONCAT, u), start, linelength) 1882 if $collectOutput then TERPRI(get_algebra_stream()) 1883 u := nextu 1884 null u => return(nil) 1885 1886prnd(start, op) == 1887 spcs := fillerSpaces(MAX(0,start - 1), '" ") 1888 $collectOutput => 1889 string := STRCONC(spcs, op) 1890 $outputLines := [string, :$outputLines] 1891 PRINTEXP(spcs, get_algebra_stream()) 1892 PRINTEXP(op, get_algebra_stream()) 1893 TERPRI(get_algebra_stream()) 1894 1895qTSub(u) == 1896 subspan CADR u 1897 1898qTSuper(u) == 1899 superspan CADR u 1900 1901qTWidth(u) == 1902 2 + WIDTH CADR u 1903 1904remWidth(x) == 1905 atom x => x 1906 true => CONS( (atom first x => first x; true => CAAR x), 1907 MMAPCAR(remWidth, rest x) ) 1908 1909subSub(u) == 1910 height CDDR u 1911 1912subSuper u == 1913 superspan u.1 1914 1915letWidth u == 1916 5 + WIDTH u.1 + WIDTH u.2 1917 1918sumoverlist(u) == +/[x for x in u] 1919 1920sumWidth u == 1921 WIDTH u.1 + sumWidthA CDDR u 1922 1923sumWidthA u == 1924 sum := 0 1925 for item in u repeat 1926 sum := sum + (if member(keyp absym item, '(_+ _-)) then 5 else 3) 1927 sum := sum + WIDTH absym item 1928 sum 1929 1930superSubApp(u, x, y, di) == 1931 a := first (u := rest u) 1932 b := first (u := rest u) 1933 c := first (u := IFCDR u) or '((NOTHING . 0)) 1934 d := IFCAR (u := IFCDR u) or '((NOTHING . 0)) 1935 e := IFCAR(IFCDR(u)) or '((NOTHING . 0)) 1936 aox := MAX(wd := WIDTH d, we := WIDTH e) 1937 ar := superspan a 1938 ab := subspan a 1939 aw := WIDTH a 1940 di := APP(d, x + (aox - wd), 1 + ar + y + subspan d, di) 1941 di := APP(a, x + aox, y, di) 1942 di := APP(c, aox + aw + x, 1 + y + ar + subspan c, di) 1943 di := APP(e, x + (aox - we), y - 1 - MAX(superspan e, ab), di) 1944 di := APP(b, aox + aw + x, y - 1 - MAX(ab, superspan b), di) 1945 return di 1946 1947stringer x == 1948 STRINGP x => x 1949 EQ('_|, FETCHCHAR(s:= STRINGIMAGE x, 0)) => 1950 RPLACSTR(s, 0, 1, "", nil, nil) 1951 s 1952 1953superSubSub u == 1954 a:= first (u:= rest u) 1955 b := IFCAR (u := IFCDR u) 1956 e := IFCAR IFCDR IFCDR IFCDR u 1957 return subspan a + MAX(height b, height e) 1958 1959binomApp(u,x,y,d) == 1960 [num,den] := rest u 1961 ysub := y - 1 - superspan den 1962 ysup := y + 1 + subspan num 1963 wden := WIDTH den 1964 wnum := WIDTH num 1965 w := MAX(wden,wnum) 1966 d := APP(den, x + 1 + QUOTIENT(w - wden, 2), ysub, d) 1967 d := APP(num, x + 1 + QUOTIENT(w - wnum, 2), ysup, d) 1968 hnum := height num 1969 hden := height den 1970 w := 1 + w 1971 for j in 0..(hnum - 1) repeat 1972 d := appChar(specialChar 'vbar,x,y + j,d) 1973 d := appChar(specialChar 'vbar,x + w,y + j,d) 1974 for j in 1..(hden - 1) repeat 1975 d := appChar(specialChar 'vbar,x,y - j,d) 1976 d := appChar(specialChar 'vbar,x + w,y - j,d) 1977 d := appChar(specialChar 'ulc,x,y + hnum,d) 1978 d := appChar(specialChar 'urc,x + w,y + hnum,d) 1979 d := appChar(specialChar 'llc,x,y - hden,d) 1980 d := appChar(specialChar 'lrc,x + w,y - hden,d) 1981 1982binomSub u == height CADDR u 1983binomSuper u == height CADR u 1984binomWidth u == 2 + MAX(WIDTH CADR u, WIDTH CADDR u) 1985 1986altSuperSubApp(u, x, y, di) == 1987 a := first (u := rest u) 1988 ar := superspan a 1989 ab := subspan a 1990 aw := WIDTH a 1991 di := APP(a, x, y, di) 1992 x := x + aw 1993 1994 sublist := everyNth(u := rest u, 2) 1995 suplist := everyNth(IFCDR u, 2) 1996 1997 ysub := y - 1 - APPLY('MAX, [ab, :[superspan s for s in sublist]]) 1998 ysup := y + 1 + APPLY('MAX, [ar, :[subspan s for s in sublist]]) 1999 for sub in sublist for sup in suplist repeat 2000 wsub := WIDTH sub 2001 wsup := WIDTH sup 2002 di := APP(sub, x, ysub, di) 2003 di := APP(sup, x, ysup, di) 2004 x := x + 1 + MAX(wsub, wsup) 2005 di 2006 2007everyNth(l, n) == 2008 [(e := l.0; for i in 1..n while l repeat l := rest l; e) while l] 2009 2010 2011altSuperSubSub u == 2012 span := subspan CADR u 2013 sublist := everyNth(CDDR u, 2) 2014 for sub in sublist repeat 2015 h := height sub 2016 if h > span then span := h 2017 span 2018 2019altSuperSubSuper u == 2020 span := superspan CADR u 2021 suplist := everyNth(IFCDR CDDR u, 2) 2022 for sup in suplist repeat 2023 h := height sup 2024 if h > span then span := h 2025 span 2026 2027altSuperSubWidth u == 2028 w := WIDTH CADR u 2029 suplist := everyNth(IFCDR CDDR u, 2) 2030 sublist := everyNth(CDDR u, 2) 2031 for sup in suplist for sub in sublist repeat 2032 wsup := WIDTH sup 2033 wsub := WIDTH sub 2034 w := w + 1 + MAX(wsup, wsub) 2035 w 2036 2037superSubWidth u == 2038 a := first (u := rest u) 2039 b := first (u := rest u) 2040 c := first (u := IFCDR u) or '((NOTHING . 0)) 2041 d := IFCAR (u := IFCDR u) or '((NOTHING . 0)) 2042 e := IFCAR(IFCDR(u)) or '((NOTHING . 0)) 2043 return MAX(WIDTH d, WIDTH e) + MAX(WIDTH b, WIDTH c) + WIDTH a 2044 2045superSubSuper u == 2046 a:= first (u := rest u) 2047 c := IFCAR (u := IFCDR IFCDR u) 2048 d := IFCAR(IFCDR(u)) 2049 return superspan a + MAX(height c, height d) 2050 2051suScWidth u == 2052 WIDTH u.1 + aggwidth CDDR u 2053 2054vconcatapp(u, x, y, d) == 2055 null rest u => d 2056 w := vConcatWidth u 2057 y := y + superspan u.1 + 1 2058 for a in rest u repeat 2059 y := y - superspan a - 1 2060 xoff := QUOTIENT(w - WIDTH a, 2) 2061 d := APP(a, x + xoff, y, d) 2062 y := y - subspan a 2063 d 2064 2065binomialApp(u, x, y, d) == 2066 [.,b,a] := u 2067 w := vConcatWidth u 2068 d := APP('"(",x,y,d) 2069 x := x + 1 2070 y1 := y - height a 2071 xoff := QUOTIENT(w - WIDTH a, 2) 2072 d := APP(a, x + xoff, y1, d) 2073 y2 := y + height b 2074 xoff := QUOTIENT(w - WIDTH b, 2) 2075 d := APP(b, x + xoff, y2, d) 2076 x := x + w 2077 APP('")",x,y,d) 2078 2079vConcatSub u == 2080 null rest u => 0 2081 subspan u.1 + +/[height a for a in CDDR u] 2082vConcatSuper u == 2083 null rest u => 0 2084 superspan u.1 2085vConcatWidth u == 2086 w := 0 2087 for a in rest u repeat if (wa := WIDTH a) > w then w := wa 2088 w 2089binomialSub u == height u.2 + 1 2090 2091binomialSuper u == height u.1 + 1 2092 2093binomialWidth u == 2 + MAX(WIDTH u.1, WIDTH u.2) 2094 2095 2096primeApp(u, x, y, di) == 2097 ["PRIME", a, b] := u 2098 superSubApp(["SUPERSUB", a, '" ", b], x, y, di) 2099 2100primeSub(u) == 2101 ["PRIME", a, b] := u 2102 superSubSub(["SUPERSUB", a, '" ", b]) 2103 2104primeSuper(u) == 2105 ["PRIME", a, b] := u 2106 superSubSuper(["SUPERSUB", a, '" ", b]) 2107 2108primeWidth(u) == 2109 ["PRIME", a, b] := u 2110 superSubWidth(["SUPERSUB", a, '" ", b]) 2111 2112-- Used only in fortout.spad 2113mathPrint u == 2114 if not $collectOutput then TERPRI(get_algebra_stream()) 2115 (u := STRINGP mathPrint1(mathPrintTran u, nil) => 2116 PSTRING u; nil) 2117 2118-- Used only by mathPrint 2119mathPrintTran u == 2120 atom u => u 2121 for x in tails u repeat 2122 rplac(first x, mathPrintTran first x) 2123 u 2124 2125-- Used only by mathPrint 2126mathPrint1(x,fg) == 2127 if fg and not $collectOutput then TERPRI(get_algebra_stream()) 2128 maPrin x 2129 if fg and not $collectOutput then TERPRI(get_algebra_stream()) 2130 2131maPrin u == 2132 null u => nil 2133 $highlightDelta := 0 2134 c := CATCH('outputFailure,charybdis(u, $MARGIN, $LINELENGTH)) 2135 c ~= 'outputFailure => c 2136 sayKeyedMsg("S2IX0009",NIL) 2137 u is ['EQUATNUM,num,form] or u is [['EQUATNUM,:.],num,form] => 2138 charybdis(['EQUATNUM,num], $MARGIN, $LINELENGTH) 2139 if not $collectOutput then 2140 TERPRI(get_algebra_stream()) 2141 PRETTYPRINT(form, get_algebra_stream()) 2142 form 2143 if not $collectOutput then PRETTYPRINT(u, get_algebra_stream()) 2144 nil 2145 2146clear_highlight() == 2147 $displaySetValue : local := nil 2148 $saveHighlight := $highlightAllowed 2149 $highlightAllowed := false 2150 $saveSpecialchars := $specialCharacters 2151 setOutputCharacters(["plain"]) 2152 2153reset_highlight() == 2154 $highlightAllowed := $saveHighlight 2155 $specialCharacters := $saveSpecialchars 2156