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