path: root/src/interp/i-output.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


import '"sys-macros"
)package "BOOT"

--Modified JHD February 1993: see files miscout.input for some tests of this
-- General principle is that maprin0 is the top-level routine,
-- which calls maprinChk to print the object (placing certain large
-- matrices on a look-aside list), then calls maprinRows to print these.
-- These prints call maprinChk recursively, and maprinChk has to ensure that
-- we do not end up in an infinite recursion: matrix1 = matrix2 ...

--% Output display routines

$defaultSpecialCharacters == [
    EBCDIC( 28),      -- upper left corner
    EBCDIC( 27),      -- upper right corner
    EBCDIC( 30),      -- lower left corner
    EBCDIC( 31),      -- lower right corner
    EBCDIC( 79),      -- vertical bar
    EBCDIC( 45),      -- horizontal bar
    EBCDIC(144),      -- APL quad
    EBCDIC(173),      -- left bracket
    EBCDIC(189),      -- right bracket
    EBCDIC(192),      -- left brace
    EBCDIC(208),      -- right brace
    EBCDIC( 59),      -- top    box tee
    EBCDIC( 62),      -- bottom box tee
    EBCDIC( 63),      -- right  box tee
    EBCDIC( 61),      -- left   box tee
    EBCDIC( 44),      -- center box tee
    EBCDIC(224)       -- back slash
     ]

$plainSpecialCharacters0 == [
    EBCDIC( 78),      -- upper left corner   (+)
    EBCDIC( 78),      -- upper right corner  (+)
    EBCDIC( 78),      -- lower left corner   (+)
    EBCDIC( 78),      -- lower right corner  (+)
    EBCDIC( 79),      -- vertical bar
    EBCDIC( 96),      -- horizontal bar      (-)
    EBCDIC(111),      -- APL quad            (?)
    EBCDIC(173),      -- left bracket
    EBCDIC(189),      -- right bracket
    EBCDIC(192),      -- left brace
    EBCDIC(208),      -- right brace
    EBCDIC( 78),      -- top    box tee      (+)
    EBCDIC( 78),      -- bottom box tee      (+)
    EBCDIC( 78),      -- right  box tee      (+)
    EBCDIC( 78),      -- left   box tee      (+)
    EBCDIC( 78),      -- center box tee      (+)
    EBCDIC(224)       -- back slash
     ]

$plainSpecialCharacters1 == [
    EBCDIC(107),      -- upper left corner   (,)
    EBCDIC(107),      -- upper right corner  (,)
    EBCDIC(125),      -- lower left corner   (')
    EBCDIC(125),      -- lower right corner  (')
    EBCDIC( 79),      -- vertical bar
    EBCDIC( 96),      -- horizontal bar      (-)
    EBCDIC(111),      -- APL quad            (?)
    EBCDIC(173),      -- left bracket
    EBCDIC(189),      -- right bracket
    EBCDIC(192),      -- left brace
    EBCDIC(208),      -- right brace
    EBCDIC( 78),      -- top    box tee      (+)
    EBCDIC( 78),      -- bottom box tee      (+)
    EBCDIC( 78),      -- right  box tee      (+)
    EBCDIC( 78),      -- left   box tee      (+)
    EBCDIC( 78),      -- center box tee      (+)
    EBCDIC(224)       -- back slash
     ]

$plainSpecialCharacters2 == [
    EBCDIC( 79),      -- upper left corner   (|)
    EBCDIC( 79),      -- upper right corner  (|)
    EBCDIC( 79),      -- lower left corner   (|)
    EBCDIC( 79),      -- lower right corner  (|)
    EBCDIC( 79),      -- vertical bar
    EBCDIC( 96),      -- horizontal bar      (-)
    EBCDIC(111),      -- APL quad            (?)
    EBCDIC(173),      -- left bracket
    EBCDIC(189),      -- right bracket
    EBCDIC(192),      -- left brace
    EBCDIC(208),      -- right brace
    EBCDIC( 78),      -- top    box tee      (+)
    EBCDIC( 78),      -- bottom box tee      (+)
    EBCDIC( 78),      -- right  box tee      (+)
    EBCDIC( 78),      -- left   box tee      (+)
    EBCDIC( 78),      -- center box tee      (+)
    EBCDIC(224)       -- back slash
     ]

$plainSpecialCharacters3 == [
    EBCDIC( 96),      -- upper left corner   (-)
    EBCDIC( 96),      -- upper right corner  (-)
    EBCDIC( 96),      -- lower left corner   (-)
    EBCDIC( 96),      -- lower right corner  (-)
    EBCDIC( 79),      -- vertical bar
    EBCDIC( 96),      -- horizontal bar      (-)
    EBCDIC(111),      -- APL quad            (?)
    EBCDIC(173),      -- left bracket
    EBCDIC(189),      -- right bracket
    EBCDIC(192),      -- left brace
    EBCDIC(208),      -- right brace
    EBCDIC( 78),      -- top    box tee      (+)
    EBCDIC( 78),      -- bottom box tee      (+)
    EBCDIC( 78),      -- right  box tee      (+)
    EBCDIC( 78),      -- left   box tee      (+)
    EBCDIC( 78),      -- center box tee      (+)
    EBCDIC(224)       -- back slash
     ]

$plainRTspecialCharacters == [
    '_+,      -- upper left corner   (+)
    '_+,      -- upper right corner  (+)
    '_+,      -- lower left corner   (+)
    '_+,      -- lower right corner  (+)
    '_|,      -- vertical bar
    '_-,      -- horizontal bar      (-)
    '_?,      -- APL quad            (?)
    '_[,      -- left bracket
    '_],      -- right bracket
    '_{,      -- left brace
    '_},      -- right brace
    '_+,      -- top    box tee      (+)
    '_+,      -- bottom box tee      (+)
    '_+,      -- right  box tee      (+)
    '_+,      -- left   box tee      (+)
    '_+,      -- center box tee      (+)
    '_\       -- back slash
     ]

makeCharacter n ==> INTERN(STRING(CODE_-CHAR n))

$RTspecialCharacters == [
    makeCharacter 218,      -- upper left corner   (+)
    makeCharacter 191,      -- upper right corner  (+)
    makeCharacter 192,      -- lower left corner   (+)
    makeCharacter 217,      -- lower right corner  (+)
    makeCharacter 179,      -- vertical bar
    makeCharacter 196,      -- horizontal bar      (-)
    $quadSymbol,      -- APL quad            (?)
    '_[,      -- left bracket
    '_],      -- right bracket
    '_{,      -- left brace
    '_},      -- right brace
    makeCharacter 194,      -- top    box tee      (+)
    makeCharacter 193,      -- bottom box tee      (+)
    makeCharacter 180,      -- right  box tee      (+)
    makeCharacter 195,      -- left   box tee      (+)
    makeCharacter 197,      -- center box tee      (+)
    '_\       -- back slash
     ]

$specialCharacters := $RTspecialCharacters

$specialCharacterAlist == '(
  (ulc  .  0)_
  (urc  .  1)_
  (llc  .  2)_
  (lrc  .  3)_
  (vbar .  4)_
  (hbar .  5)_
  (quad .  6)_
  (lbrk .  7)_
  (rbrk .  8)_
  (lbrc .  9)_
  (rbrc . 10)_
  (ttee . 11)_
  (btee . 12)_
  (rtee . 13)_
  (ltee . 14)_
  (ctee . 15)_
  (bslash . 16)_
  )

$collectOutput := nil

specialChar(symbol) ==
  -- looks up symbol in $specialCharacterAlist, gets the index
  -- into the EBCDIC table, and returns the appropriate character
  null (code := IFCDR ASSQ(symbol,$specialCharacterAlist)) => '"?"
  ELT($specialCharacters,code)

rbrkSch() == PNAME specialChar 'rbrk
lbrkSch() == PNAME specialChar 'lbrk
quadSch() == PNAME specialChar 'quad

isBinaryInfix x ==
    x in '(_= _+ _- _* _/ _*_* _^ "=" "+" "-" "*" "/" "**" "^")

stringApp([.,u],x,y,d) ==
  appChar(STRCONC($DoubleQuote,atom2String u,$DoubleQuote),x,y,d)

stringWidth u ==
  u is [.,u] or THROW('outputFailure,'outputFailure)
  2+#u

obj2String o ==
  atom o =>
    STRINGP o => o
    o = " " => '" "
    o = ")" => '")"
    o = "(" => '"("
    STRINGIMAGE o
  APPLY('STRCONC,[obj2String o' for o' in o])

APP(u,x,y,d) ==
  atom u => appChar(atom2String u,x,y,d)
  u is [[op,:.],a] and (s:= GETL(op,'PREFIXOP)) =>
    GETL(op,'isSuffix) => appChar(s,x+WIDTH a,y,APP(a,x,y,d))
    APP(a,x+#s,y,appChar(s,x,y,d))
  u is [[id,:.],:.] =>
    fn := GETL(id,'APP) => FUNCALL(fn,u,x,y,d)
    not NUMBERP id and (d':= appInfix(u,x,y,d))=> d'
    appelse(u,x,y,d)
  appelse(u,x,y,d)

atom2String x ==
  IDENTP x => PNAME x
  STRINGP x => x
  stringer x

-- General convention in the "app..." functions:
-- Added from an attempt to fix bugs by JHD: 2 Aug 89
-- the first argument is what has to be printed
-- the second - x - is the horizontal distance along the page
--      at which to start
-- the third - y - is some vertical hacking control
-- the foruth - d - is the "layout" so far
-- these functions return an updated "layout so far" in general

appChar(string,x,y,d) ==
  if CHARP string then string := PNAME string
  line:= LASSOC(y,d) =>
    if MAXINDEX string = 1 and char(string.0) = "%" then
      string.1="b" =>
        bumpDeltaIfTrue:= true
        string.0:= EBCDIC 29
        string.1:= EBCDIC 200
      string.1="d" =>
        bumpDeltaIfTrue:= true
        string.0:= EBCDIC 29
        string.1:= EBCDIC 65
    shiftedX:= (y=0 => x+$highlightDelta; x)
      --shift x for brightening characters -- presently only if y=0
    RPLACSTR(line,shiftedX,n:=#string,string,0,n)
    if bumpDeltaIfTrue=true then $highlightDelta:= $highlightDelta+1
    d
  appChar(string,x,y,nconc(d,[[y,:GETFULLSTR(10+$LINELENGTH+$MARGIN," ")]]))

print(x,domain) ==
  dom:= devaluate domain
  $InteractiveMode: local:= true
  $dontDisplayEquatnum: local:= true
  output(x,dom)

mathprintWithNumber x ==
  x:= outputTran x
  maprin
    $IOindex => ['EQUATNUM,$IOindex,x]
    x

mathprint x == 
   x := outputTran x
   $saturn => texFormat1 x
   maprin x

sayMath u ==
  for x in u repeat acc:= concat(acc,linearFormatName x)
  sayALGEBRA acc

--% Output transformations

outputTran x ==
  x in '("failed" "nil" "prime" "sqfr" "irred") =>
    STRCONC('"_"",x,'"_"")
  STRINGP x => x
  VECP x =>
    outputTran ['BRACKET,['AGGLST,:[x.i for i in 0..MAXINDEX x]]]
  NUMBERP x =>
    MINUSP x => ["-",MINUS x]
    x
  atom x =>
    x=$EmptyMode => specialChar 'quad
    x
  x is [c,var,mode] and c in '(_pretend _: _:_: _@) =>
    var := outputTran var
    if PAIRP var then var := ['PAREN,var]
    ['CONCATB,var,c,obj2String prefix2String mode]
  x is ['ADEF,vars,.,.,body] =>
    vars :=
        vars is [x] => x
        ['Tuple,:vars]
    outputTran ["+->", vars, body]
  x is ['MATRIX,:m] => outputTranMatrix m
  x is ['matrix,['construct,c]] and
    c is ['COLLECT,:m,d] and d is ['construct,e] and e is ['COLLECT,:.] =>
      outputTran ['COLLECT,:m,e]
  x is ['LIST,:l] => outputTran ['BRACKET,['AGGLST,:l]]
  x is ['MAP,:l] => outputMapTran l
  x is ['brace, :l]    =>
    ['BRACE,  ['AGGLST,:[outputTran y for y in l]]]
  x is ["return",l] => ["return",outputTran l]
  x is ["return",.,:l] => ["return",:outputTran l]
  x is ["construct",:l] =>
    ['BRACKET,['AGGLST,:[outputTran y for y in l]]]

  x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or
    domain is ['Float]) and INTEGERP x and INTEGERP y and INTEGERP z and
        z > 0  and (float := getFunctionFromDomain("float",domain,[$Integer,$Integer,$PositiveInteger])) =>
            f := SPADCALL(x,y,z,float)
            o := coerceInteractive(objNewWrap(f, domain), '(OutputForm))
            objValUnwrap o

  [op,:l]:= flattenOps x
  --needed since "op" is string in some spad code
  if STRINGP op then (op := INTERN op; x:= [op,:l])
  op = 'LAMBDA_-CLOSURE => 'Closure
  x is ['break,:.] => 'break
  x is ['SEGMENT,a] =>
    a' := outputTran a
    if LISTP a' then a' := ['PAREN,a']
    ['SEGMENT,a']
  x is ['SEGMENT,a,b] =>
    a' := outputTran a
    b' := outputTran b
    if LISTP a' then a' := ['PAREN,a']
    if LISTP b' then b' := ['PAREN,b']
    ['SEGMENT,a',b']

  op is ["$elt",targ,fun] or not $InteractiveMode and op is ["elt",targ,fun] =>
    -- l has the args
    targ' := obj2String prefix2String targ
    if 2 = #targ then targ' := ['PAREN,targ']
    ['CONCAT,outputTran [fun,:l],'"$",targ']
  x is ["$elt",targ,c] or not $InteractiveMode and x is ["elt",targ,c] =>
    targ' := obj2String prefix2String targ
    if 2 = #targ then targ' := ['PAREN,targ']
    ['CONCAT,outputTran c,'"$",targ']
  x is ["-",a,b] =>
    a := outputTran a
    b := outputTran b
    INTEGERP b =>
      b < 0 => ["+",a,-b]
      ["+",a,["-",b]]
    b is ["-",c] => ["+",a,c]
    ["+",a,["-",b]]

  -- next stuff translates exp(log(foo4)/foo3) into ROOT(foo4,foo3)
  (x is ["**", ='"%e",foo1]) and (foo1 is [ ='"/",foo2, foo3]) and
    INTEGERP(foo3) and (foo2 is ['log,foo4]) =>
       foo3 = 2 => ['ROOT,outputTran foo4]
       ['ROOT,outputTran foo4,outputTran foo3]
  (x is ["**", ='"%e",foo1]) and (foo1 is [op',foo2, foo3]) and
    (op' = '"*") and ((foo3 is ['log,foo4]) or (foo2 is ['log,foo4])) =>
       foo3 is ['log,foo4] =>
         ["**", outputTran foo4, outputTran foo2]
       foo4 := CADR foo2
       ["**", outputTran foo4, outputTran foo3]
  op = 'IF       => outputTranIf x
  op = 'COLLECT  => outputTranCollect x
  op = 'REDUCE   => outputTranReduce x
  op = 'REPEAT   => outputTranRepeat x
  op = 'SEQ      => outputTranSEQ x
  op in '(cons nconc) => outputConstructTran x
  l:= [outputTran y for y in l]
  op = "*" =>
     l is [a] => outputTran a
     l is [["-",a],:b] =>
       -- now this is tricky because we've already outputTran the list
       -- expect trouble when outputTran hits b again 
       -- some things object to being outputTran twice ,e.g.matrices
       -- same thing a bit lower down for "/" 
       a=1 => outputTran ["-",[op,:b]]
       outputTran ["-",[op,a,:b]]
     [op,:"append"/[(ss is ["*",:ll] => ll; [ss]) for ss in l]]
  op = "+" =>
     l is [a] => outputTran a
     [op,:"append"/[(ss is ["+",:ll] => ll; [ss]) for ss in l]]
  op = "/" =>
    if $fractionDisplayType = 'horizontal then op := 'SLASH
    else op := 'OVER
    l is [["-",a],:b] => outputTran ["-",[op,a,:b]]
    [outputTran op,:l]
  op="|" and l is [["Tuple",:u],pred] =>
    ['PAREN,["|",['AGGLST,:l],pred]]
  op='Tuple  => ['PAREN,['AGGLST,:l]]
  op='LISTOF => ['AGGLST,:l]
  IDENTP op and ^(op in '(_* _*_*) ) and char("*") = (PNAME op).0 =>
    mkSuperSub(op,l)
  [outputTran op,:l]

-- The next two functions are designed to replace successive instances of
-- binary functions with the n-ary equivalent, cutting down on recursion
-- in outputTran and in partciular allowing big polynomials to be printed
-- without stack overflow.  MCD.
flattenOps l ==
  [op, :args ] := l
  op in ['"+",'"*","+","*"] =>
    [op,:checkArgs(op,args)]
  l

checkArgs(op,tail) ==
  head := []
  while tail repeat
    term := first tail
    atom term =>
      head := [term,:head]
      tail := rest tail
    not LISTP term => -- never happens?
      head := [term,:head]
      tail := rest tail
    op=first term =>
      tail := [:rest term,:rest tail]
    head := [term,:head]
    tail := rest tail
  REVERSE head
   
outputTranSEQ ['SEQ,:l,exitform] ==
  if exitform is ['exit,.,a] then exitform := a
  ['SC,:[outputTran x for x in l],outputTran exitform]

outputTranIf ['IF,x,y,z] ==
  y = '%noBranch =>
    ['CONCATB,'if,['CONCATB,'not,outputTran x],'then,outputTran z]
  z = '%noBranch =>
    ['CONCATB,'if,outputTran x,'then,outputTran y]
  y' := outputTran y
  z' := outputTran z
--y' is ['SC,:.] or z' is ['SC,:.] =>
-- ['CONCATB,'if,outputTran x,
--   ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]]
--['CONCATB,'if,outputTran x,'then,outputTran y,'else,outputTran z]
  ['CONCATB,'if,outputTran x,
    ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]]

outputMapTran l ==
  null l => NIL         -- should not happen

  -- display subscripts linearly
  $linearFormatScripts : local := true

  -- get the real names of the parameters
  alias := get($op,'alias,$InteractiveFrame)

  rest l =>             -- if multiple forms, call repeatedly
    ['SC,:[outputMapTran0(ll,alias) for ll in l]]
  outputMapTran0(first l,alias)

outputMapTran0(argDef,alias) ==
  arg := first argDef
  def := rest  argDef
  [arg',:def'] := simplifyMapPattern(argDef,alias)
  arg' := outputTran arg'
  if null arg' then arg' := '"()"
  ['CONCATB,$op,outputTran arg',"==",outputTran def']

outputTranReduce ['REDUCE,op,.,body] ==
  ['CONCAT,op,"/",outputTran body]

outputTranRepeat ["REPEAT",:itl,body] ==
  body' := outputTran body
  itl =>
    itlist:= outputTranIteration itl
    ['CONCATB,itlist,'repeat,body']
  ['CONCATB,'repeat,body']

outputTranCollect [.,:itl,body] ==
  itlist:= outputTranIteration itl
  ['BRACKET,['CONCATB,outputTran body,itlist]]

outputTranIteration itl ==
  null rest itl => outputTranIterate first itl
  ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl]

outputTranIterate x ==
  x is ['STEP,n,init,step,:final] =>
    init' := outputTran init
    if LISTP init then init' := ['PAREN,init']
    final' :=
      final =>
        LISTP first final => [['PAREN,outputTran first final]]
        [outputTran first final]
      NIL
    ['STEP,outputTran n,init',outputTran step,:final']
  x is ["IN",n,s] => ["IN",outputTran n,outputTran s]
  x is [op,p] and op in '(_| UNTIL WHILE) =>
    op:= DOWNCASE op
    ['CONCATB,op,outputTran p]
  throwKeyedMsg("S2IX0008",['outputTranIterate,['"illegal iterate: ",x]])

outputConstructTran x ==
  x is [op,a,b] =>
    a:= outputTran a
    b:= outputTran b
    op="cons" =>
      b is ['construct,:l] => ['construct,a,:l]
      ['BRACKET,['AGGLST,:[a,[":",b]]]]
    op="nconc" =>
      aPart :=
        a is ['construct,c] and c is ['SEGMENT,:.] => c
        [":",a]
      b is ['construct,:l] => ['construct,aPart,:l]
      ['BRACKET,['AGGLST,aPart,[":",b]]]
    [op,a,b]
  atom x => x
  [outputTran first x,:outputConstructTran rest x]

outputTranMatrix x ==
  not VECP x =>
    -- assume that the only reason is that we've been done before
    ["MATRIX",:x]
    --keyedSystemError("S2GE0016",['"outputTranMatrix",
    -- '"improper internal form for matrix found in output routines"])
  ["MATRIX",nil,:[outtranRow x.i for i in 0..MAXINDEX x]] where
    outtranRow x ==
      not VECP x =>
        keyedSystemError("S2GE0016",['"outputTranMatrix",
          '"improper internal form for matrix found in output routines"])
      ["ROW",:[outputTran x.i for i in 0..MAXINDEX x]]

mkSuperSub(op,argl) ==
  $linearFormatScripts => linearFormatForm(op,argl)
--  l := [(STRINGP f => f; STRINGIMAGE f)
--    for f in linearFormatForm(op,argl)]
--  "STRCONC"/l
  s:= PNAME op
  indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while
    (DIGITP (d:= s.(maxIndex:= i)))]
  cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s])
  -- if there is just a subscript use the SUB special form
  #indexList=2 =>
    subPart:= ['SUB,cleanOp,:take(indexList.1,argl)]
    l:= drop(indexList.1,argl) => [subPart,:l]
    subPart
  -- otherwise use the SUPERSUB form
  superSubPart := NIL
  for i in rest indexList repeat
    scripts :=
      this:= take(i,argl)
      argl:= drop(i,argl)
      i=0 => ['AGGLST]
      i=1 => first this
      ['AGGLST,:this]
    superSubPart := cons(scripts,superSubPart)
  superSub := ['SUPERSUB,cleanOp,:reverse superSubPart]
  argl => [superSub,:argl]
  superSub

timesApp(u,x,y,d) ==
  rightPrec:= getOpBindingPower("*","Led","right")
  firstTime:= true
  for arg in rest u repeat
    op:= keyp arg
    if ^firstTime and (needBlankForRoot(lastOp,op,arg) or
       needStar(wasSimple,wasQuotient,wasNumber,arg,op) or
        wasNumber and op = 'ROOT and subspan arg = 1) then
      d:= APP(BLANK,x,y,d)
      x:= x+1
    [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg
    wasSimple:= atom arg and not NUMBERP arg or isRationalNumber arg
    wasQuotient:= isQuotient op
    wasNumber:= NUMBERP arg
    lastOp := op
    firstTime:= nil
  d

needBlankForRoot(lastOp,op,arg) ==
  lastOp ^= "^" and lastOp ^= "**" and not(subspan(arg)>0) => false
  op = "**" and keyp CADR arg = 'ROOT => true
  op = "^" and keyp CADR arg = 'ROOT => true
  op = 'ROOT and CDDR arg => true
  false

stepApp([.,a,init,one,:optFinal],x,y,d) ==
  d:= appChar('"for ",x,y,d)
  d:= APP(a,w:=x+4,y,d)
  d:= appChar('" in ",w:=w+WIDTH a,y,d)
  d:= APP(init,w:=w+4,y,d)
  d:= APP('"..",w:=w+WIDTH init,y,d)
  if optFinal then d:= APP(first optFinal,w+2,y,d)
  d

stepSub [.,a,init,one,:optFinal] ==
  m:= MAX(subspan a,subspan init)
  optFinal => MAX(m,subspan first optFinal)
  m

stepSuper [.,a,init,one,:optFinal] ==
  m:= MAX(superspan a,superspan init)
  optFinal => MAX(m,superspan first optFinal)
  m

stepWidth [.,a,init,one,:optFinal] ==
   10+WIDTH a+WIDTH init+(optFinal => WIDTH first optFinal; 0)

inApp([.,a,s],x,y,d) ==  --for [IN,a,s]
  d:= appChar('"for ",x,y,d)
  d:= APP(a,x+4,y,d)
  d:= appChar('" in ",x+WIDTH a+4,y,d)
  APP(s,x+WIDTH a+8,y,d)

inSub [.,a,s] == MAX(subspan a,subspan s)

inSuper [.,a,s] == MAX(superspan a,superspan s)

inWidth [.,a,s] == 8+WIDTH a+WIDTH s

centerApp([.,u],x,y,d) ==
  d := APP(u,x,y,d)

concatApp([.,:l],x,y,d) == concatApp1(l,x,y,d,0)

concatbApp([.,:l],x,y,d) == concatApp1(l,x,y,d,1)

concatApp1(l,x,y,d,n) ==
  for u in l repeat
    d:= APP(u,x,y,d)
    x:=x+WIDTH u+n
  d

concatSub [.,:l] == "MAX"/[subspan x for x in l]

concatSuper [.,:l] == "MAX"/[superspan x for x in l]

concatWidth [.,:l] == +/[WIDTH x for x in l]

concatbWidth [.,:l] == +/[1+WIDTH x for x in l]-1

exptApp([.,a,b],x,y,d) ==
  pren:= exptNeedsPren a
  d:=
    pren => appparu(a,x,y,d)
    APP(a,x,y,d)
  x':= x+WIDTH a+(pren => 2;0)
  y':= 1+y+superspan a+subspan b + (0=superspan a => 0; -1)
  APP(b,x',y',d)

exptNeedsPren a ==
  atom a and null (INTEGERP a and a < 0)  => false
  key:= keyp a
  key = "OVER" => true  -- added JHD 2/Aug/90
  (key="SUB") or (null GETL(key,"Nud") and null GETL(key,"Led")) => false
  true

exptSub u == subspan CADR u

exptSuper [.,a,b] == superspan a+height b+(superspan a=0 => 0;-1)

exptWidth [.,a,b] == WIDTH a+WIDTH b+(exptNeedsPren a => 2;0)

needStar(wasSimple,wasQuotient,wasNumber,cur,op) ==
  wasQuotient or isQuotient op => true
  wasSimple =>
    atom cur or keyp cur="SUB" or isRationalNumber cur or op="**" or op = "^" or
      (atom op and ^NUMBERP op and ^GETL(op,"APP"))
  wasNumber =>
    NUMBERP(cur) or isRationalNumber cur or
        ((op="**" or op ="^") and NUMBERP(CADR cur))

isQuotient op ==
  op="/" or op="OVER"

timesWidth u ==
  rightPrec:= getOpBindingPower("*","Led","right")
  firstTime:= true
  w:= 0
  for arg in rest u repeat
    op:= keyp arg
    if ^firstTime and needStar(wasSimple,wasQuotient,wasNumber,arg,op) then
      w:= w+1
    if infixArgNeedsParens(arg, rightPrec, "left") then w:= w+2
    w:= w+WIDTH arg
    wasSimple:= atom arg and not NUMBERP arg --or isRationalNumber arg
    wasQuotient:= isQuotient op
    wasNumber:= NUMBERP arg
    firstTime:= nil
  w

plusApp([.,frst,:rst],x,y,d) ==
  appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d))

appSum(u,x,y,d) ==
  for arg in u repeat
    infixOp:=
      syminusp arg => "-"
      "+"
    opString:= GETL(infixOp,"INFIXOP") or '","
    d:= APP(opString,x,y,d)
    x:= x+WIDTH opString
    arg:= absym arg --negate a neg. number or remove leading "-"
    rightPrec:= getOpBindingPower(infixOp,"Led","right")
    if infixOp = "-" then rightPrec:=rightPrec  +1
    -- that +1 added JHD 2 Aug 89 to prevent x-(y+z) printing as x-y+z
    -- Sutor found the example:
    -- )cl all
    -- p : P[x] P I := x - y - z
    -- p :: P[x] FR P I
    -- trailingCoef %
    [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg
  d

appInfix(e,x,y,d) ==
  op := keyp e
  leftPrec:= getOpBindingPower(op,"Led","left")
  leftPrec = 1000 => return nil --no infix operator is allowed default value
  rightPrec:= getOpBindingPower(op,"Led","right")
  #e < 2 => throwKeyedMsg("S2IX0008",['appInfix,
      '"fewer than 2 arguments to an infix function"])
  opString:= GETL(op,"INFIXOP") or '","
  opWidth:= WIDTH opString
  [.,frst,:rst]:= e
  null rst =>
    GETL(op,"isSuffix") =>
      [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString)
      d:= appChar(opString,x,y,d)
    THROW('outputFailure,'outputFailure)
  [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) --app in left arg
  for arg in rst repeat
    d:= appChar(opString,x,y,d) --app in the infix operator
    x:= x+opWidth
    [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",opString) --app in right arg
  d

appconc(d,x,y,w) == NCONC(d,[[[x,:y],:w]])

infixArgNeedsParens(arg, prec, leftOrRight) ==
  prec > getBindingPowerOf(leftOrRight, arg) + 1

appInfixArg(u,x,y,d,prec,leftOrRight,string) ==
  insertPrensIfTrue:= infixArgNeedsParens(u,prec,leftOrRight)
  d:=
    insertPrensIfTrue => appparu(u,x,y,d)
    APP(u,x,y,d)
  x:= x+WIDTH u
  if string then d:= appconc(d,x,y,string)
  [d,(insertPrensIfTrue => x+2; x)]

leftBindingPowerOf(x, ind) ==
  y := GETL(x, ind)
  y => ELEMN(y, 3, 0)
  0

rightBindingPowerOf(x, ind) ==
  y := GETL(x, ind)
  y => ELEMN(y, 4, 105)
  105

getBindingPowerOf(key,x) ==
  --binding powers can be found in file NEWAUX LISP
  x is ['REDUCE,:.] => (key='left => 130; key='right => 0)
  x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0)
  x is ["COND",:.] => (key="left" => 130; key="right" => 0)
  x is [op,:argl] =>
    if op is [a,:.] then op:= a
    op = 'SLASH => getBindingPowerOf(key,["/",:argl]) - 1
    op = 'OVER  => getBindingPowerOf(key,["/",:argl])
    (n:= #argl)=1 =>
      key="left" and (m:= getOpBindingPower(op,"Nud","left")) => m
      key="right" and (m:= getOpBindingPower(op,"Nud","right")) => m
      1000
    n>1 =>
      key="left" and (m:= getOpBindingPower(op,"Led","left")) => m
      key="right" and (m:= getOpBindingPower(op,"Led","right")) => m
      op="ELT" => 1002
      1000
    1000
  1002

getOpBindingPower(op,LedOrNud,leftOrRight) ==
  if op in '(SLASH OVER) then op := "/"
  exception:=
    leftOrRight="left" => 0
    105
  bp:=
    leftOrRight="left" => leftBindingPowerOf(op,LedOrNud)
    rightBindingPowerOf(op,LedOrNud)
  bp^=exception => bp
  1000

--% Brackets
bracketApp(u,x,y,d) ==
  u is [.,u] or THROW('outputFailure,'outputFailure)
  d:= appChar(specialChar 'lbrk,x,y,d)
  d:=APP(u,x+1,y,d)
  appChar(specialChar 'rbrk,x+1+WIDTH u,y,d)

--% Braces
braceApp(u,x,y,d) ==
  u is [.,u] or THROW('outputFailure,'outputFailure)
  d:= appChar(specialChar 'lbrc,x,y,d)
  d:=APP(u,x+1,y,d)
  appChar(specialChar 'rbrc,x+1+WIDTH u,y,d)

--% Aggregates
aggWidth u ==
  rest u is [a,:l] => WIDTH a + +/[1+WIDTH x for x in l]
  0

aggSub u == subspan rest u

aggSuper u == superspan rest u

aggApp(u,x,y,d) == aggregateApp(rest u,x,y,d,",")

aggregateApp(u,x,y,d,s) ==
  if u is [a,:l] then
    d:= APP(a,x,y,d)
    x:= x+WIDTH a
    for b in l repeat
      d:= APP(s,x,y,d)
      d:= APP(b,x+1,y,d)
      x:= x+1+WIDTH b
  d

--% Function to compute Width

outformWidth u ==  --WIDTH as called from OUTFORM to do a COPY
  STRINGP u =>
    u = $EmptyString => 0
    u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1
    #u
  atom u => # atom2String u
  WIDTH COPY u

WIDTH u ==
  STRINGP u =>
    u = $EmptyString => 0
    u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1
    #u
  INTEGERP u => 
    if (u < 1) then 
      negative := 1
      u := -u
    else
      negative := 0
    -- Try and be fairly exact for smallish integers:
    u = 0 => 1
    u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR ((LOG10 u) + 0.0000001)
    -- Rough guess: integer-length returns log2 rounded up, so divide it by
    -- roughly log2(10). This should return an over-estimate, but for objects
    -- this big does it matter?
    FLOOR(INTEGER_-LENGTH(u)/3.3)
  atom u => # atom2String u
  putWidth u is [[.,:n],:.] => n
  THROW('outputFailure,'outputFailure)

putWidth u ==
  atom u or u is [[.,:n],:.] and NUMBERP n => u
  op:= keyp u
--NUMBERP op => nil
  leftPrec:= getBindingPowerOf("left",u)
  rightPrec:= getBindingPowerOf("right",u)
  [firstEl,:l] := u
  interSpace:=
    SYMBOLP firstEl and GETL(firstEl,"INFIXOP") => 0
    1
  argsWidth:=
    l is [firstArg,:restArg] =>
      RPLACA(rest u,putWidth firstArg)
      for y in tails restArg repeat RPLACA(y,putWidth first y)
      widthFirstArg:=
        0=interSpace and infixArgNeedsParens(firstArg,leftPrec,"right")=>
          2+WIDTH firstArg
        WIDTH firstArg
      widthFirstArg + +/[interSpace+w for x in restArg] where w() ==
        0=interSpace and infixArgNeedsParens(x, rightPrec, "left") =>
          2+WIDTH x
        WIDTH x
    0
  newFirst:=
    atom (oldFirst:= first u) =>
      fn:= GETL(oldFirst,"WIDTH") =>
        [oldFirst,:FUNCALL(fn,[oldFirst,:l])]
      if l then ll := rest l else ll := nil
      [oldFirst,:opWidth(oldFirst,ll)+argsWidth]
    [putWidth oldFirst,:2+WIDTH oldFirst+argsWidth]
  RPLACA(u,newFirst)
  u

opWidth(op,has2Arguments) ==
  op = "EQUATNUM" => 4
  NUMBERP op => 2+SIZE STRINGIMAGE op
  null has2Arguments =>
    a:= GETL(op,"PREFIXOP") => SIZE a
    2+SIZE PNAME op
  a:= GETL(op,"INFIXOP") => SIZE a
  2+SIZE PNAME op

matrixBorder(x,y1,y2,d,leftOrRight) ==
  y1 = y2 =>
    c :=
      leftOrRight = 'left => specialChar('lbrk)
      specialChar('rbrk)
    APP(c,x,y1,d)
  for y in y1..y2 repeat
    c :=
      y = y1 =>
        leftOrRight = 'left => specialChar('llc)
        specialChar('lrc)
      y = y2 =>
        leftOrRight = 'left => specialChar('ulc)
        specialChar('urc)
      specialChar('vbar)
    d := APP(c,x,y,d)
  d

isRationalNumber x == nil

widthSC u == 10000

--% The over-large matrix package

maprinSpecial(x,$MARGIN,$LINELENGTH) == maprin0 x
-- above line changed JHD 13/2/93 since it used to call maPrin

maprin x ==
  if $demoFlag=true then recordOrCompareDemoResult x
  CATCH('output,maprin0 x)
  nil

maprin0 x ==
  $MatrixCount:local :=0
  $MatrixList:local :=nil
  maprinChk x
  if $MatrixList then maprinRows $MatrixList
  -- above line moved JHD 28/2/93 to catch all routes through maprinChk

maprinChk x ==
  null $MatrixList => maPrin x
  ATOM x and (u:= assoc(x,$MatrixList)) =>
    $MatrixList := delete(u,$MatrixList)
    maPrin deMatrix CDR u
  x is ["=",arg,y]  =>     --case for tracing with )math and printing matrices
    u:=assoc(y,$MatrixList) =>
      -- we don't want to print matrix1 = matrix2 ...
      $MatrixList := delete(u,$MatrixList)
      maPrin ["=",arg, deMatrix CDR u]
    maPrin x
  x is ['EQUATNUM,n,y] =>
    $MatrixList is [[name,:value]] and y=name =>
      $MatrixList:=[]   -- we are pulling this one off
      maPrin ['EQUATNUM,n, deMatrix value]
    IDENTP y => --------this part is never called
      -- Not true: JHD 28/2/93
      -- m:=[[1,2,3],[4,5,6],[7,8,9]]
      -- mm:=[[m,1,0],[0,m,1],[0,1,m]]
      -- and try to print mm**5
      u := assoc(y,$MatrixList)
      --$MatrixList := deleteAssoc(first u,$MatrixList)
      -- deleteAssoc no longer exists
      $MatrixList := delete(u,$MatrixList)
      maPrin ['EQUATNUM,n,rest u]
      if ^$collectOutput then TERPRI $algebraOutputStream
    maPrin x
  maPrin x
  -- above line added JHD 13/2/93 since otherwise x gets lost

maprinRows matrixList ==
  if ^$collectOutput then TERPRI($algebraOutputStream)
  while matrixList repeat
    y:=NREVERSE matrixList
    --Makes the matrices come out in order, since CONSed on backwards
    matrixList:=nil
    firstName := first first y
    for [name,:m] in y for n in 0.. repeat
      if ^$collectOutput then TERPRI($algebraOutputStream)
      andWhere := (name = firstName => '"where "; '"and ")
      line := STRCONC(andWhere, PNAME name)
      maprinChk ["=",line,m]
      -- note that this could place a new element on $MatrixList, hence the loop

deMatrix m ==
    ['BRACKET,['AGGLST,
        :[['BRACKET,['AGGLST,:rest row]] for row in CDDR m]]]

LargeMatrixp(u,width, dist) ==
  --  sees if there is a matrix wider than 'width' in the next 'dist'
  --  part of u, a sized charybdis structure.
  --  NIL if not, first such matrix if there is one
  ATOM u => nil
  CDAR u <= width => nil
       --CDAR is the width of a charybdis structure
  op:=CAAR u
  op = 'MATRIX => largeMatrixAlist u
         --We already know the structure is more than 'width' wide
  MEMQ(op,'(LET RARROW SEGMENT _- CONCAT CONCATB PAREN BRACKET BRACE)) =>
      --Each of these prints the arguments in a width 3 smaller
    dist:=dist-3
    width:=width-3
    ans:=
      for v in CDR u repeat
        (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans
        dist:=dist - WIDTH v
        dist<0 => return nil
    ans
      --Relying that falling out of a loop gives nil
  MEMQ(op,'(_+ _* )) =>
      --Each of these prints the first argument in a width 3 smaller
    (ans:=LargeMatrixp(CADR u,width-3,dist)) => largeMatrixAlist ans
    n:=3+WIDTH CADR u
    dist:=dist-n
    ans:=
      for v in CDDR u repeat
        (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans
        dist:=dist - WIDTH v
        dist<0 => return nil
    ans
      --Relying that falling out of a loop gives nil
  ans:=
    for v in CDR u repeat
      (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans
      dist:=dist - WIDTH v
      dist<0 => return nil
  ans
    --Relying that falling out of a loop gives nil

largeMatrixAlist u ==
  u is [op,:r] =>
    op is ['MATRIX,:.] => deMatrix u
    largeMatrixAlist op or largeMatrixAlist r
  nil

PushMatrix m ==
    --Adds the matrix to the look-aside list, and returns a name for it
  name:=
    for v in $MatrixList repeat
        EQUAL(m,CDR v) => return CAR v
  name => name
  name:=INTERNL('"matrix",STRINGIMAGE($MatrixCount:=$MatrixCount+1))
  $MatrixList:=[[name,:m],:$MatrixList]
  name

quoteApp([.,a],x,y,d) == APP(a,x+1,y,appChar(PNAME "'",x,y,d))

quoteSub [.,a] == subspan a

quoteSuper [.,a] == superspan a

quoteWidth [.,a] == 1 + WIDTH a

SubstWhileDesizing(u,m) ==
    -- arg. m is always nil (historical: EU directive to increase argument lists 1991/XGII)     
    --Replaces all occurrences of matrix m by name in u
    --Taking out any outdated size information as it goes
  ATOM u => u
  [[op,:n],:l]:=u
  --name := RASSOC(u,$MatrixList) => name
  -- doesn't work since RASSOC seems to use an EQ test, and returns the
  -- pair anyway. JHD 28/2/93
  op = 'MATRIX =>
    l':=SubstWhileDesizingList(CDR l,m)
    u :=
      -- CDR l=l' => u
      -- this was a CONS-saving optimisation, but it doesn't work JHD 28/2/93
      [op,nil,:l']
    PushMatrix u
  l':=SubstWhileDesizingList(l,m)
  -- [op,:l']
  ATOM op => [op,:l']
  [SubstWhileDesizing(op,m),:l']

--;SubstWhileDesizingList(u,m) ==
--;  -- m is always nil (historical)
--;  u is [a,:b] =>
--;    a':=SubstWhileDesizing(a,m)
--;    b':=SubstWhileDesizingList(b,m)
--;-- MCD & TTT think that this test is unnecessary and expensive
--;--    a=a' and b=b' => u
--;    [a',:b']
--;  u

SubstWhileDesizingList(u,m) ==
   u is [a,:b] =>
     res:= 
       ATOM a => [a] 
       [SubstWhileDesizing(a,m)] 
     tail:=res
     for i in b repeat
        if ATOM i then  RPLACD(tail,[i]) else RPLACD(tail,[SubstWhileDesizing(i,m)])
        tail:=CDR tail
     res   
   u  

--% Printing of Sigmas , Pis and Intsigns

sigmaSub u ==
       --The depth function for sigmas with lower limit only
  MAX(1 + height CADR u, subspan CADDR u)

sigmaSup u ==
       --The height function for sigmas with lower limit only
  MAX(1, superspan CADDR u)

sigmaApp(u,x,y,d) ==
  u is [.,bot,arg] or THROW('outputFailure,'outputFailure)
  bigopAppAux(bot,nil,arg,x,y,d,'sigma)

sigma2App(u,x,y,d) ==
  [.,bot,top,arg]:=u
  bigopAppAux(bot,top,arg,x,y,d,'sigma)

bigopWidth(bot,top,arg,kind) ==
  kindWidth := (kind = 'pi => 5; 3)
  MAX(kindWidth,WIDTH bot,(top => WIDTH top; 0)) + 2 + WIDTH arg

half x ==>
  QUOTIENT(x, 2)

bigopAppAux(bot,top,arg,x,y,d,kind) ==
  botWidth := (bot => WIDTH bot; 0)
  topWidth := WIDTH top
  opWidth :=
    kind = 'pi => 5
    3
  maxWidth := MAX(opWidth,botWidth,topWidth)
  xCenter := half(maxWidth-1) + x
  d:=APP(arg,x+2+maxWidth,y,d)
  d:=
      atom bot and SIZE atom2String bot = 1 => APP(bot,xCenter,y-2,d)
      APP(bot,x + half(maxWidth - botWidth),y-2-superspan bot,d)
  if top then
    d:=
      atom top and SIZE atom2String top = 1 => APP(top,xCenter,y+2,d)
      APP(top,x + half(maxWidth - topWidth),y+2+subspan top,d)
  delta := (kind = 'pi => 2; 1)
  opCode :=
    kind = 'sigma =>
      [['(0 .  0),:'">"],_
       ['(0 .  1),:specialChar('hbar)],_
       ['(0 . -1),:specialChar('hbar)],_
       ['(1 .  1),:specialChar('hbar)],_
       ['(1 . -1),:specialChar('hbar)],_
       ['(2 .  1),:specialChar('urc )],_
       ['(2 . -1),:specialChar('lrc )]]
    kind = 'pi =>
      [['(0 .  1),:specialChar('ulc )],_
       ['(1 .  0),:specialChar('vbar)],_
       ['(1 .  1),:specialChar('ttee)],_
       ['(1 . -1),:specialChar('vbar)],_
       ['(2 .  1),:specialChar('hbar)],_
       ['(3 .  0),:specialChar('vbar)],_
       ['(3 .  1),:specialChar('ttee)],_
       ['(3 . -1),:specialChar('vbar)],_
       ['(4 .  1),:specialChar('urc )]]
    THROW('outputFailure,'outputFailure)
  xLate(opCode,xCenter - delta,y,d)

sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma)
sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma)

sigma2Sub u ==
       --The depth function for sigmas with 2 limits
  MAX(1 + height CADR u, subspan CADDDR u)

sigma2Sup u ==
       --The depth function for sigmas with 2 limits
  MAX(1 + height CADDR u, superspan CADDDR u)

piSub u ==
       --The depth function for pi's (products)
  MAX(1 + height CADR u, subspan CADDR u)

piSup u ==
       --The height function for pi's (products)
  MAX(1, superspan CADDR u)

piApp(u,x,y,d) ==
  u is [.,bot,arg] or THROW('outputFailure,'outputFailure)
  bigopAppAux(bot,nil,arg,x,y,d,'pi)

piWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'pi)
pi2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'pi)

pi2Sub u ==
       --The depth function for pi's with 2 limits
  MAX(1 + height CADR u, subspan CADDDR u)

pi2Sup u ==
       --The depth function for pi's with 2 limits
  MAX(1 + height CADDR u, superspan CADDDR u)

pi2App(u,x,y,d) ==
  [.,bot,top,arg]:=u
  bigopAppAux(bot,top,arg,x,y,d,'pi)

overlabelSuper [.,a,b] == 1 + height a + superspan b

overlabelWidth [.,a,b] == WIDTH b

overlabelApp([.,a,b], x, y, d) ==
  underApp:= APP(b,x,y,d)
  endPoint := x + WIDTH b - 1
  middle := QUOTIENT(x + endPoint,2)
  h := y + superspan b + 1
  d := APP(a,middle,h + 1,d)
  apphor(x,x+WIDTH b-1,y+superspan b+1,d,"|")

overbarSuper u == 1 + superspan u.1

overbarWidth u == WIDTH u.1

overbarApp(u,x,y,d) ==
  underApp:= APP(u.1,x,y,d)
  apphor(x,x+WIDTH u.1-1,y+superspan u.1+1,d,UNDERBAR)

indefIntegralSub u ==
   -- form is INDEFINTEGRAL(expr,dx)
   MAX(1,subspan u.1,subspan u.2)

indefIntegralSup u ==
   -- form is INDEFINTEGRAL(expr,dx)
   MAX(1,superspan u.1,superspan u.2)

indefIntegralApp(u,x,y,d) ==
   -- form is INDEFINTEGRAL(expr,dx)
  [.,expr,dx]:=u
  d := APP(expr,x+4,y,d)
  d := APP(dx,x+5+WIDTH expr,y,d)
  xLate( [['(0 . -1),:specialChar('llc) ],_
          ['(1 . -1),:specialChar('lrc) ],_
          ['(1 .  0),:specialChar('vbar)],_
          ['(1 .  1),:specialChar('ulc) ],_
          ['(2 .  1),:specialChar('urc) ]], x,y,d)

indefIntegralWidth u ==
  -- form is INDEFINTEGRAL(expr,dx)
  # u ^= 3 => THROW('outputFailure,'outputFailure)
  5 + WIDTH u.1 + WIDTH u.2

intSub u ==
   MAX(1 + height u.1, subspan u.3)

intSup u ==
   MAX(1 + height u.2, superspan u.3)

intApp(u,x,y,d) ==
  [.,bot,top,arg]:=u
  d:=APP(arg,x+4+MAX(-4 + WIDTH bot, WIDTH top),y,d)
  d:=APP(bot,x,y-2-superspan bot,d)
  d:=APP(top,x+3,y+2+subspan top,d)
  xLate( [['(0 . -1),:specialChar('llc) ],_
          ['(1 . -1),:specialChar('lrc) ],_
          ['(1 .  0),:specialChar('vbar)],_
          ['(1 .  1),:specialChar('ulc) ],_
          ['(2 .  1),:specialChar('urc) ]], x,y,d)

intWidth u ==
  # u < 4 => THROW('outputFailure,'outputFailure)
  MAX(-4 + WIDTH u.1, WIDTH u.2) + WIDTH u.3 + 5

xLate(l,x,y,d) ==
  for [[a,:b],:c] in l repeat
    d:= appChar(c,x+a,y+b,d)
  d

concatTrouble(u,d,start,lineLength,$addBlankIfTrue) ==
  [x,:l] := splitConcat(u,lineLength,true)
  null l =>
    sayALGEBRA ['%l,'%b,'"  Too wide to Print",'%d]
    THROW('output,nil)
  charybdis(fixUp x,start,lineLength)
  for y in l repeat
    if d then prnd(start,d)
    if lineLength > 2 then
       charybdis(fixUp y,start+2,lineLength-2) -- JHD needs this to avoid lunacy
      else charybdis(fixUp y,start,1) -- JHD needs this to avoid lunacy
  BLANK
 where
  fixUp x ==
    rest x =>
      $addBlankIfTrue => ['CONCATB,:x]
      ["CONCAT",:x]
    first x

splitConcat(list,maxWidth,firstTimeIfTrue) ==
  null list => nil
  -- split list l into a list of n lists, each of which
  -- has width < maxWidth
  totalWidth:= 0
  oneOrZero := ($addBlankIfTrue => 1; 0)
  l := list
  maxW:= (firstTimeIfTrue => maxWidth; maxWidth-2)
  maxW < 1 => [[x] for x in l] -- JHD 22.8.95, otherwise things can break
  for x in tails l
    while (width := oneOrZero + WIDTH first x + totalWidth) < maxW repeat
      l:= x
      totalWidth:= width
  x:= rest l
  RPLAC(rest l,nil)
  [list,:splitConcat(x,maxWidth,nil)]

spadPrint(x,m) ==
  m = $NoValueMode => x
  if ^$collectOutput then TERPRI $algebraOutputStream
  output(x,m)
  if ^$collectOutput then TERPRI $algebraOutputStream

formulaFormat expr ==
  sff := '(ScriptFormulaFormat)
  formatFn := getFunctionFromDomain("coerce",sff,[$OutputForm])
  displayFn := getFunctionFromDomain("display",sff,[sff])
  SPADCALL(SPADCALL(expr,formatFn),displayFn)
  if ^$collectOutput then
    TERPRI $algebraOutputStream
    FORCE_-OUTPUT $formulaOutputStream
  NIL

texFormat expr ==
  tf := '(TexFormat)
  formatFn := 
    getFunctionFromDomain("convert",tf,[$OutputForm,$Integer])
  displayFn := getFunctionFromDomain("display",tf,[tf])
  SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn)
  TERPRI $texOutputStream
  FORCE_-OUTPUT $texOutputStream
  NIL

texFormat1 expr ==
  tf := '(TexFormat)
  formatFn := getFunctionFromDomain("coerce",tf, [$OutputForm])
  displayFn := getFunctionFromDomain("display",tf,[tf])
  SPADCALL(SPADCALL(expr,formatFn),displayFn)
  TERPRI $texOutputStream
  FORCE_-OUTPUT $texOutputStream
  NIL

output(expr,domain) ==
  if isWrapped expr then expr := unwrap expr
  isMapExpr expr =>
    if $formulaFormat then formulaFormat expr
    if $texFormat     then texFormat expr
    if $algebraFormat then mathprintWithNumber expr
  categoryForm? domain or domain in '((Mode) (Domain) (SubDomain (Domain))) =>
    if $algebraFormat then
      mathprintWithNumber outputDomainConstructor expr
    if $texFormat     then
      texFormat outputDomainConstructor expr
  T := coerceInteractive(objNewWrap(expr,domain),$OutputForm) =>
    x := objValUnwrap T
    if $formulaFormat then formulaFormat x
    if $fortranFormat then
      dispfortexp x
      if ^$collectOutput then TERPRI $fortranOutputStream
      FORCE_-OUTPUT $fortranOutputStream
    if $algebraFormat then
      mathprintWithNumber x
    if $texFormat     then texFormat x
  (FUNCTIONP(opOf domain)) and
    (printfun := compiledLookup("<<",'(TextWriter TextWriter $), evalDomain domain))
       and (textwrit := compiledLookup("print", '($), TextWriter())) =>
     sayMSGNT [:bright '"AXIOM-XL",'"output:   "]
     SPADCALL(SPADCALL textwrit, expr, printfun)
     sayMSGNT '%l

  -- big hack for tuples for new compiler
  domain is ['Tuple, S] => output(asTupleAsList expr, ['List, S])

  sayALGEBRA [:bright '"LISP",'"output:",'%l,expr or '"NIL"]

outputNumber(start,linelength,num) ==
  if start > 1 then blnks := fillerSpaces(start-1,'" ")
  else blnks := '""
  under:='"__"
  firsttime:=(linelength>3)
  if linelength>2 then
     linelength:=linelength-1 
  while SIZE(num) > linelength repeat
    if $collectOutput then
       $outputLines := [CONCAT(blnks, SUBSTRING(num,0,linelength),under),
                        :$outputLines]
    else
      sayALGEBRA [blnks,
                  SUBSTRING(num,0,linelength),under]
    num := SUBSTRING(num,linelength,NIL)
    if firsttime then 
         blnks:=CONCAT(blnks,'" ")
         linelength:=linelength-1
         firsttime:=NIL
  if $collectOutput then
    $outputLines := [CONCAT(blnks, num), :$outputLines]
  else
    sayALGEBRA [blnks, num]

outputString(start,linelength,str) ==
  if start > 1 then blnks := fillerSpaces(start-1,'" ")
  else blnks := '""
  while SIZE(str) > linelength repeat
    if $collectOutput then
       $outputLines := [CONCAT(blnks, SUBSTRING(str,0,linelength)),
                        :$outputLines]
    else
      sayALGEBRA [blnks, SUBSTRING(str,0,linelength)]
    str := SUBSTRING(str,linelength,NIL)
  if $collectOutput then
    $outputLines := [CONCAT(blnks, str), :$outputLines]
  else
    sayALGEBRA [blnks, str]

outputDomainConstructor form ==
  if VECTORP form then form := devaluate form
  atom (u:= prefix2String form) => u
  v:= [object2String(x) for x in u]
  return INTERNL eval ['STRCONC,:v]

getOutputAbbreviatedForm form ==
  form is [op,:argl] =>
    op in '(Union Record) => outputDomainConstructor form
    op is "Mapping" => formatMapping argl
    u:= constructor? op or op
    null argl => u
    ml:= getPartialConstructorModemapSig(op)
    argl:= [fn for x in argl for m in ml] where fn() ==
      categoryForm?(m) => outputDomainConstructor x
      x' := coerceInteractive(objNewWrap(x,m),$OutputForm)
      x' => objValUnwrap x'
      '"unprintableObject"
    [u,:argl]
  form

outputOp x ==
  x is [op,:args] and (GETL(op,"LED") or GETL(op,"NUD")) =>
    n:=
      GETL(op,"NARY") => 2
      #args
    newop:= INTERN STRCONC("*",STRINGIMAGE n,PNAME op)
    [newop,:[outputOp y for y in args]]
  x

--% MAP PRINTER (FROM EV BOOT)

printMap u ==
  printBasic specialChar 'lbrk
  initialFlag:= isInitialMap u
  if u is [x,:l] then
    printMap1(x,initialFlag and x is [[n],:.] and n=1)
    for y in l repeat (printBasic " , "; printMap1(y,initialFlag))
  printBasic specialChar 'rbrk
  if ^$collectOutput then TERPRI $algebraOutputStream

isInitialMap u ==
  u is [[[n],.],:l] and INTEGERP n and
    (and/[x is [[ =i],.] for x in l for i in n+1..])

printMap1(x,initialFlag) ==
  initialFlag => printBasic CADR x
  if CDAR x then printBasic first x else printBasic CAAR x
  printBasic " E "
  printBasic CADR x

printBasic x ==
  x='(One) => PRIN1(1,$algebraOutputStream)
  x='(Zero) => PRIN1(0,$algebraOutputStream)
  IDENTP x => PRINTEXP(PNAME x,$algebraOutputStream)
  atom x => PRIN1(x,$algebraOutputStream)
  PRIN0(x,$algebraOutputStream)

charybdis(u,start,linelength) ==
  EQ(keyp u,'EQUATNUM) and ^(CDDR u) =>
    charybdis(['PAREN,u.1],start,linelength)
  charyTop(u,start,linelength)

charyTop(u,start,linelength) ==
  u is ['SC,:l] or u is [['SC,:.],:l] =>
    for a in l repeat charyTop(a,start,linelength)
    '" "
  u is [['CONCATB,:.],:m,[['SC,:.],:l]] =>
    charyTop(['CONCATB,:m],start,linelength)
    charyTop(['SC,:l],start+2,linelength-2)
  u is ['CENTER,a] =>
    b := charyTopWidth a
    (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength)
    charyTop(b,half(linelength-start-w),linelength)
  v := charyTopWidth u
  EQ(keyp u,'ELSE) => charyElse(u,v,start,linelength)
  WIDTH(v) > linelength => charyTrouble(u,v,start,linelength)
  d := APP(v,start,0,nil)
  n := superspan v
  m := - subspan v
-->
  $testOutputLineFlag =>
    $testOutputLineList :=
      [:ASSOCRIGHT SORTBY('CAR,d),:$testOutputLineList]
  until n < m repeat
    scylla(n,d)
    n := n - 1
  '" "

charyTopWidth u ==
    atom u => u
    atom first u => putWidth u
    NUMBERP CDAR u => u
    putWidth u

charyTrouble(u,v,start,linelength) ==
  al:= LargeMatrixp(u,linelength,2*linelength) =>
    --$MatrixList =>
      --[[m,:m1]] := al
      --maPrin sublisMatAlist(m,m1,u)
      --above three lines commented out JHD 25/2/93 since don't work
    --u := SubstWhileDesizing(u,first first al)
    u := SubstWhileDesizing(u,nil)
    maprinChk u
  charyTrouble1(u,v,start,linelength)

sublisMatAlist(m,m1,u) ==
  u is [op,:r] =>
    op is ['MATRIX,:.] and u=m => m1
    op1 := sublisMatAlist(m,m1,op)
    r1 := [sublisMatAlist(m,m1,s) for s in r]
    op = op1 and r1 = r => u
    [op1,:r1]
  u

charyTrouble1(u,v,start,linelength) ==
  NUMBERP u => outputNumber(start,linelength,atom2String u)
  atom u => outputString(start,linelength,atom2String u)
  EQ(x:= keyp u,'_-) => charyMinus(u,v,start,linelength)
  MEMQ(x,'(_+ _* AGGLST)) => charySplit(u,v,start,linelength)
  EQ(x,'EQUATNUM) => charyEquatnum(u,v,start,linelength)
  d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength)
  x = 'OVER  =>
    charyBinary(GETL("/",'INFIXOP),u,v,start,linelength)
  EQ(3,LENGTH u) and GETL(x,'Led) =>
    d:= PNAME first GETL(x,'Led)
    charyBinary(d,u,v,start,linelength)
  EQ(x,'CONCAT) =>
    concatTrouble(rest v,d,start,linelength,nil)
  EQ(x,'CONCATB) =>
    (rest v) is [loop, 'repeat, body] =>
      charyTop(['CONCATB,loop,'repeat],start,linelength)
      charyTop(body,start+2,linelength-2)
    (rest v) is [wu, loop, 'repeat, body] and
      (keyp wu) is ['CONCATB,wu',.] and wu' in '(while until) =>
        charyTop(['CONCATB,wu,loop,'repeat],start,linelength)
        charyTop(body,start+2,linelength-2)
    concatTrouble(rest v,d,start,linelength,true)
  GETL(x,'INFIXOP) => charySplit(u,v,start,linelength)
  EQ(x,'PAREN) and
    (EQ(keyp u.1,'AGGLST) and (v:= ",") or EQ(keyp u.1,'AGGSET) and
      (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)")
  EQ(x,'PAREN) and EQ(keyp u.1,'CONCATB) =>
    bracketagglist(rest u.1,start,linelength," ","_(","_)")
  EQ(x,'BRACKET) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) =>
    bracketagglist(rest u.1,start,linelength,v,
                   specialChar 'lbrk, specialChar 'rbrk)
  EQ(x,'BRACE) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) =>
    bracketagglist(rest u.1,start,linelength,v,
                   specialChar 'lbrc, specialChar 'rbrc)
  EQ(x,'EXT) => longext(u,start,linelength)
  EQ(x,'MATRIX) => MATUNWND()
  EQ(x,'ELSE) => charyElse(u,v,start,linelength)
  EQ(x,'SC) => charySemiColon(u,v,start,linelength)
  charybdis(x,start,linelength)
  if rest u then charybdis(['ELSE,:rest u],start,linelength)
  -- changed from charybdis(...) by JHD 2 Aug 89, since rest u might be null
  '" "

charySemiColon(u,v,start,linelength) ==
  for a in rest u repeat
    charyTop(a,start,linelength)
  nil

charyMinus(u,v,start,linelength) ==
  charybdis('"-",start,linelength)
  charybdis(v.1,start+3,linelength-3)
  '" "

charyBinary(d,u,v,start,linelength) ==
  d in '(" := " "= ") =>
    charybdis(['CONCATB,v.1,d],start,linelength)
    charybdis(v.2,start+2,linelength-2)
    '" "
  charybdis(v.1,start+2,linelength-2)
  if d then prnd(start,d)
  charybdis(v.2,start+2,linelength-2)
  '" "

charyEquatnum(u,v,start,linelength) ==
  charybdis(['PAREN,u.1],start,linelength)
  charybdis(u.2,start,linelength)
  '" "

charySplit(u,v,start,linelength) ==
  v:= [first v.0,:rest v]
  m:= rest v
  WIDTH v.1 > linelength-2 =>
    charybdis(v.1,start+2,linelength-2)
    ^(CDDR v) => '" "
    dm:= CDDR v
    ddm:= rest dm
    split2(u,dm,ddm,start,linelength)
  for i in 0.. repeat
    dm := rest m
    ddm := rest dm
    RPLACD(dm,nil)
    WIDTH v > linelength - 2 => return nil
    RPLAC(first v, first v.0)
    RPLACD(dm,ddm)
    m := rest m
  RPLAC(first v,first v.0)
  RPLACD(m,nil)
  charybdis(v,start + 2,linelength - 2)
  split2(u,dm,ddm,start,linelength)

split2(u,dm,ddm,start,linelength) ==
--prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; opSrch(keyp u,OPLIST)))
  prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; '","))
  RPLACD(dm,ddm)
  m:= WIDTH [keyp u,:dm]<linelength-2
  charybdis([keyp u,:dm],(m => start+2; start),(m => linelength-2; linelength))
  '" "

charyElse(u,v,start,linelength) ==
  charybdis(v.1,start+3,linelength-3)
  ^(CDDR u) => '" "
  prnd(start,'",")
  charybdis(['ELSE,:CDDR v],start,linelength)
  '" "

scylla(n,v) ==
  y := LASSOC(n,v)
  null y => nil
  if STRINGP(y) then y := DROPTRAILINGBLANKS COPY y
  if $collectOutput then
    $outputLines := [y, :$outputLines]
  else
    PRINTEXP(y,$algebraOutputStream)
    TERPRI $algebraOutputStream
  nil

keyp(u) ==
  atom u => nil
  atom first u => first u
  CAAR u

absym x ==
  (NUMBERP x) and (MINUSP x) => -x
  ^(atom x) and (keyp(x) = '_-) => CADR x
  x

agg(n,u) ==
  (n = 1) => CADR u
  agg(n - 1, rest u)

aggwidth u ==
  null u => 0
  null rest u => WIDTH first u
  1 + (WIDTH first u) + (aggwidth rest u)

argsapp(u,x,y,d) == appargs(rest u,x,y,d)

subspan u ==
  atom u => 0
  NUMBERP rest u => subspan first u
  (not atom first u             and_
   atom CAAR u           and_
   not NUMBERP CAAR u    and_
   GETL(CAAR u, 'SUBSPAN)    )    =>
   APPLX(GETL(CAAR u, 'SUBSPAN), LIST u)
  MAX(subspan first u, subspan rest u)

agggsub u == subspan rest u

superspan u ==
  atom u => 0
  NUMBERP rest u => superspan first u
  (not atom first u               and_
   atom CAAR u             and_
   not NUMBERP CAAR u      and_
   GETL(CAAR u, 'SUPERSPAN)    )    =>
   APPLX(GETL(CAAR u, 'SUPERSPAN), LIST u)
  MAX(superspan first u, superspan rest u)

agggsuper u == superspan rest u

agggwidth u == aggwidth rest u

appagg(u,x,y,d) == appagg1(u,x,y,d,'",")

appagg1(u,x,y,d,s) ==
  null u => d
  null rest u => APP(first u,x,y,d)
  temp := x + WIDTH first u
  temparg1 := APP(first u,x,y,d)
  temparg2 := APP(s,temp,y,temparg1)
  appagg1(rest u, 1 + temp, y, temparg2,s)

--Note the similarity between the definition below of appargs and above
--of appagg. (why?)

appargs(u,x,y,d) == appargs1(u,x,y,d,'";")

--Note that the definition of appargs1 below is identical to that of
--appagg1 above except that the former calls appargs and the latter
--calls appagg.

appargs1(u,x,y,d,s) ==
  null u => d
  null rest u => APP(first u,x,y,d)
  temp := x + WIDTH first u
  temparg1 := APP(first u,x,y,d)
  temparg2 := APP(s,temp,y,temparg1)
  true => appargs(rest u, 1 + temp, y, temparg2)

apprpar(x, y, y1, y2, d) ==
  (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('")", x, y, d)
  true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d))

apprpar1(x, y, y1, y2, d) ==
  (y1 = y2) => APP('")", x, y2, d)
  true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d))

applpar(x, y, y1, y2, d) ==
  (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('"(", x, y, d)
  true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d))

applpar1(x, y, y1, y2, d) ==
  (y1 = y2) => APP('"(", x, y2, d)
  true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d))

--The body of the function appelse assigns 6 local variables.
--It then finishes by calling apprpar.

appelse(u,x,y,d) ==
  w := WIDTH CAAR u
  b := y - subspan rest u
  p := y + superspan rest u
  temparg1 := APP(keyp u, x, y, d)
  temparg2 := applpar(x + w, y, b, p, temparg1)
  temparg3 := appagg(rest u, x + 1 + w, y, temparg2)
  apprpar(x + 1 + w + aggwidth rest u, y, b, p, temparg3)

appext(u,x,y,d) ==
  xptr := x
  yptr := y - (subspan CADR u + superspan agg(3,u) + 1)
  d := APP(CADR u,x,y,d)
  d := APP(agg(2,u),xptr,yptr,d)
  xptr := xptr + WIDTH agg(2,u)
  d := APP('"=", xptr, yptr,d)
  d := APP(agg(3,u), 1 + xptr, yptr, d)
  yptr := y + 1 + superspan CADR u + SUBSPAD agg(4,u)
  d := APP(agg(4,u), x, yptr, d)
  temp := 1 + WIDTH agg(2,u) +  WIDTH agg(3,u)
  n := MAX(WIDTH CADR u, WIDTH agg(4,u), temp)
  if EQCAR(first(z := agg(5,u)), 'EXT) and
   (EQ(n,3) or (n > 3 and ^(atom z)) ) then
     n := 1 + n
  d := APP(z, x + n, y, d)

apphor(x1,x2,y,d,char) ==
  temp := (x1 = x2 => d; apphor(x1, x2 - 1, y, d,char))
  APP(char, x2, y, temp)

syminusp x ==
  NUMBERP x => MINUSP x
  ^(atom x) and EQ(keyp x,'_-)

appsum(u, x, y, d) ==
  null u => d
  ac := absym first u
  sc :=
    syminusp first u => '"-"
    true => '"+"
  dp := member(keyp absym first u, '(_+ _-))
  tempx := x + WIDTH ac + (dp => 5; true => 3)
  tempdblock :=
    temparg1 := APP(sc, x + 1, y, d)
    dp =>
      bot := y - subspan ac
      top := y + superspan ac
      temparg2 := applpar(x + 3, y, bot, top, temparg1)
      temparg3 := APP(ac, x + 4, y, temparg2)
      apprpar(x + 4 + WIDTH ac, y, bot, top, temparg3)
    true => APP(ac, x + 3, y, temparg1)
  appsum(rest u, tempx, y, tempdblock)

appneg(u, x, y, d) ==
  appsum(LIST u, x - 1, y, d)

appparu(u, x, y, d) ==
  bot := y - subspan u
  top := y + superspan u
  temparg1 := applpar(x, y, bot, top, d)
  temparg2 := APP(u, x + 1, y, temparg1)
  apprpar(x + 1 + WIDTH u, y, bot, top, temparg2)

appparu1(u, x, y, d) ==
  appparu(CADR u, x, y, d)

appsc(u, x, y, d) ==
  appagg1(rest u, x, y, d, '";")

appsetq(u, x, y, d) ==
  w := WIDTH first u
  temparg1 := APP(CADR u, x, y, d)
  temparg2 := APP('":", x + w, y, temparg1)
  APP(CADR rest u, x + 2 + w, y, temparg2)

appsub(u, x, y, d) ==
  temparg1 := x + WIDTH CADR u
  temparg2 := y - 1 - superspan CDDR u
  temparg3 := APP(CADR u, x, y, d)
  appagg(CDDR u, temparg1, temparg2, temparg3)

starstarcond(l, iforwhen) ==
    null l => l
    EQ((a := CAAR l), 1) =>
       LIST('CONCAT, CADR first l, '" OTHERWISE")
    EQCAR(a, 'COMPARG) =>
      starstarcond(CONS(transcomparg(CADR a),  rest l), iforwhen)
    null rest l =>
      LIST('CONCAT, CADR first l,
           LIST('CONCAT, iforwhen, CAAR l))
    true => LIST('VCONCAT,
                 starstarcond(CONS(first l, nil), iforwhen),
                 LIST('VCONCAT, '"  ",
                      starstarcond(rest l, iforwhen)))

eq0(u) == 0

height(u) ==
  superspan(u) + 1 + subspan(u)

extsub(u) ==
  MAX(subspan agg(5, u), height(agg(3, u)), subspan CADR u  )

extsuper(u) ==
  MAX(superspan CADR u + height agg(4, u), superspan agg(5, u) )

extwidth(u) ==
  n := MAX(WIDTH CADR u,
           WIDTH agg(4, u),
           1 + WIDTH agg(2, u) + WIDTH agg(3, u) )
  nil or
         (EQCAR(first(z := agg(5, u)), 'EXT) and _
          (EQ(n, 3) or ((n > 3) and null atom z) )  =>
          n := 1 + n)
  true => n + WIDTH agg(5, u)

appfrac(u, x, y, d) ==
  -- Added "1+" to both QUOTIENT statements so that when exact centering is
  -- not possible, expressions are offset to the right rather than left.
  -- MCD 16-8-95
  w := WIDTH u
  tempx := x + QUOTIENT(1+w - WIDTH CADR rest u, 2)
  tempy := y - superspan CADR rest u - 1
  temparg3 := APP(CADR rest u, tempx, tempy, d)
  temparg4 := apphor(x, x + w - 1, y, temparg3,specialChar('hbar))
  APP(CADR u,
        x + QUOTIENT(1+w - WIDTH CADR u, 2),
          y + 1 + subspan CADR u,
            temparg4)

fracsub(u) == height CADR rest u

fracsuper(u) == height CADR u

fracwidth(u) ==
  numw := WIDTH (num := CADR u)
  denw := WIDTH (den := CADDR u)
  if num is [[op,:.],:.] and op = 'OVER then numw := numw + 2
  if den is [[op,:.],:.] and op = 'OVER then denw := denw + 2
  MAX(numw,denw)

slashSub u ==
  MAX(1,subspan(CADR u),subspan(CADR rest u))

slashSuper u ==
  MAX(1,superspan(CADR u),superspan(CADR rest u))

slashApp(u, x, y, d) ==
  -- to print things as a/b as opposed to
  --      a
  --      -
  --      b
  temparg1 := APP(CADR u, x, y, d)
  temparg2 := APP('"/", x + WIDTH CADR u, y, temparg1)
  APP(CADR rest u,
     x + 1 + WIDTH CADR u, y, temparg2)

slashWidth(u) ==
  -- to print things as a/b as opposed to
  --      a
  --      -
  --      b
  1 + WIDTH CADR u + WIDTH CADR rest u

longext(u, i, n) ==
  x := REVERSE u
  y := first x
  u := remWidth(REVERSEWOC(CONS('" ", rest x)))
  charybdis(u, i, n)
  if ^$collectOutput then TERPRI $algebraOutputStream
  charybdis(CONS('ELSE, LIST y), i, n)
  '" "

appvertline(char, x, yl, yu, d) ==
  yu < yl => d
  temparg :=  appvertline(char, x, yl, yu - 1, d)
  true => APP(char, x, yu, temparg)

appHorizLine(xl, xu, y, d) ==
  xu < xl => d
  temparg :=  appHorizLine(xl, xu - 1, y, d)
  true => APP(MATBORCH, xu, y, temparg)

rootApp(u, x, y, d) ==
  widB := WIDTH u.1
  supB := superspan u.1
  subB := subspan u.1
  if #u > 2 then
    widR := WIDTH u.2
    subR := subspan u.2
    d    := APP(u.2,  x, y - subB + 1 + subR, d)
  else
    widR := 1
  d := APP(u.1, x + widR + 1, y, d)
  d := apphor(x+widR+1, x+widR+widB, y+supB+1, d, specialChar('hbar))
  d := appvertline(specialChar('vbar), x+widR, y - subB, y + supB, d)
  d := APP(specialChar('ulc), x+widR, y + supB+1, d)
  d := APP(specialChar('urc), x + widR + widB + 1, y + supB+1, d)
  d := APP(specialChar('bslash), x + widR - 1, y - subB, d)

boxApp(u, x, y, d) ==
  CDDR u => boxLApp(u, x, y, d)
  a := 1 + superspan u.1
  b := 1 + subspan u.1
  w := 2 + WIDTH u.1
  d := appvertline(specialChar('vbar), x,y - b + 1, y + a - 1, d)
  d := appvertline(specialChar('vbar), x + w + 1, y - b,y + a,d)
  d := apphor(x + 1, x + w, y - b, d, specialChar('hbar))
  d := apphor(x + 1, x + w, y + a, d, specialChar('hbar))
  d := APP(specialChar('ulc), x,         y + a, d)
  d := APP(specialChar('urc), x + w + 1, y + a, d)
  d := APP(specialChar('llc), x,         y - b, d)
  d := APP(specialChar('lrc), x + w + 1, y - b, d)
  d := APP(u.1, 2 + x, y, d)

boxLApp(u, x, y, d) ==
  la := superspan u.2
  lb := subspan u.2
  lw := 2 + WIDTH u.2
  lh := 2 + la + lb
  a := superspan u.1+1
  b := subspan u.1+1
  w := MAX(lw, 2 + WIDTH u.1)
  -- next line used to have h instead of lh
  top := y + a + lh
  d := appvertline(MATBORCH, x, y - b, top, d)
  d := appHorizLine(x + 1, x + w, top, d)
  d := APP(u.2, 2 + x, y + a + lb + 1, d)
  d := appHorizLine(x + 1, x + lw, y + a, d)
  nil or
     lw < w => d := appvertline(MATBORCH, x + lw + 1, y + a, top - 1, d)
  d := APP(u.1, 2 + x, y, d)
  d := appHorizLine(x + 1, x + w, y - b, top, d)
  d := appvertline(MATBORCH, x + w + 1, y - b, top, d)

boxSub(x) ==
  subspan x.1+1

boxSuper(x) ==
  null CDR x => 0
  hl :=
    null CDDR x => 0
    true => 2 + subspan x.2 + superspan x.2
  true => hl+1 + superspan x.1

boxWidth(x) ==
  null CDR x => 0
  wl :=
    null CDDR x => 0
    true => WIDTH x.2
  true => 4 + MAX(wl, WIDTH x.1)

nothingWidth x ==
    0
nothingSuper x ==
    0
nothingSub x ==
    0
nothingApp(u, x, y, d) ==
    d

zagApp(u, x, y, d) ==
    w := WIDTH u
    denx := x + QUOTIENT(w - WIDTH CADR rest u, 2)
    deny := y - superspan CADR rest u - 1
    d    := APP(CADR rest u, denx, deny, d)
    numx := x + QUOTIENT(w - WIDTH CADR u, 2)
    numy := y+1 + subspan CADR u
    d    := APP(CADR u, numx, numy, d)
    a := 1 + zagSuper u
    b := 1 + zagSub u
    d := appvertline(specialChar('vbar), x,         y - b, y - 1, d)
    d := appvertline(specialChar('vbar), x + w - 1, y + 1, y + a, d)
    d := apphor(x, x + w - 2, y, d, specialChar('hbar))
    d := APP(specialChar('ulc), x, y, d)
    d := APP(specialChar('lrc), x + w - 1, y, d)

zagSub(u) ==
    height CADR rest u

zagSuper(u) ==
    height CADR u

zagWidth(x) ==
   #x = 1 => 0
   #x = 2 => 4 + WIDTH x.1
   4 + MAX(WIDTH x.1, WIDTH x.2)

rootWidth(x) ==
   #x <= 2 => 3 + WIDTH x.1
   2 + WIDTH x.1 + WIDTH x.2

rootSub(x) ==
   subspan x.1

rootSuper(x) ==
   normal := 1 + superspan x.1
   #x <= 2 => normal
   (radOver := height x.2 - height x.1) < 0 => normal
   normal + radOver

appmat(u, x, y, d) ==
   rows := CDDR u
   p := matSuper u
   q := matSub u
   d := matrixBorder(x, y - q, y + p, d, 'left)
   x := 1 + x
   yc := 1 + y + p
   w := CADR u
   wl := CDAR w
   subl := rest CADR w
   superl := rest CADR rest w
   repeat
      null rows => return(matrixBorder(x + WIDTH u - 2,
                                       y - q,
                                       y + p,
                                       d,
                                       'right))
      xc := x
      yc := yc - 1 - first superl
      w := wl
      row := CDAR rows
      repeat
            if flag = '"ON" then
               flag := '"OFF"
               return(nil)
            null row =>
                  repeat
                     yc := yc - 1 - first subl
                     subl := rest subl
                     superl := rest superl
                     rows := rest rows
                     return(flag  := '"ON"; nil)
            d := APP(first row,
                     xc + QUOTIENT(first w - WIDTH first row, 2),
                     yc,
                     d)
            xc := xc + 2 + first w
            row := rest row
            w := rest w

matSuper(x) ==
  (x := x.1) => -1 + QUOTIENT(first x.1 + first x.2, 2)
  true => ERROR('MAT)

matSub(x) ==
  (x := x.1) => QUOTIENT(-1 + first x.1 + first x.2, 2)
  true => ERROR('MAT)

matWidth(x) ==
  y := CDDR x  -- list of rows, each of form ((ROW . w) element element ...)
  numOfColumns := LENGTH CDAR y
  widthList := matLSum2 matWList(y, NLIST(numOfColumns, 0))
    --returns ["max width of entries in column i" for i in 1..numberOfRows]
  subspanList := matLSum matSubList y
  superspanList := matLSum matSuperList y
  RPLAC(x.1,[widthList, subspanList, superspanList])
  CAAR x.1

matLSum(x) ==
  CONS(sumoverlist x + LENGTH x, x)

matLSum2(x) ==
  CONS(sumoverlist x + 2*(LENGTH x), x)

matWList(x, y) ==
  null x => y
  true => matWList(rest x, matWList1(CDAR x, y) )

matWList1(x, y) ==
  null x => nil
  true => CONS(MAX(WIDTH first x, first y), matWList1(rest x, rest y) )

matSubList(x) ==  --computes the max/[subspan(e) for e in "row named x"]
  null x => nil
  true => CONS(matSubList1(CDAR x, 0), matSubList(rest x) )

matSubList1(x, y) ==
  null x => y
  true => matSubList1(rest x, MAX(y, subspan first x) )

matSuperList(x) ==  --computes the max/[superspan(e) for e in "row named x"]
  null x => nil
  true => CONS(matSuperList1(CDAR x, 0), matSuperList(rest x) )

matSuperList1(x, y) ==
  null x => y
  true => matSuperList1(rest x, MAX(y, superspan first x) )

minusWidth(u) ==
  -1 + sumWidthA rest u

-- opSrch(name, x) ==
--   LASSOC(name, x) or '","

bracketagglist(u, start, linelength, tchr, open, close) ==
  u := CONS(LIST('CONCAT, open, first u),
            [LIST('CONCAT, '" ", y) for y in rest u] )
  repeat
    s := 0
    for x in tails u repeat
             lastx := x
             ((s := s + WIDTH first x + 1) >= linelength) => return(s)
             null rest x => return(s := -1)
    nil or
       EQ(s, -1) => (nextu := nil)
       EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) )
       true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil))
    for x in tails u repeat
           RPLACA(x, LIST('CONCAT, first x, tchr))
    if null nextu then RPLACA(CDDR LAST u, close)
    x := ASSOCIATER('CONCAT, CONS(ichr, u))
    charybdis(ASSOCIATER('CONCAT, u), start, linelength)
    if $collectOutput then TERPRI $algebraOutputStream
    ichr := '" "
    u := nextu
    null u => return(nil)

prnd(start, op) ==
-->
  $testOutputLineFlag =>
    string := STRCONC(fillerSpaces MAX(0,start - 1),op)
    $testOutputLineList := [string,:$testOutputLineList]
  PRINTEXP(fillerSpaces MAX(0,start - 1),$algebraOutputStream)
  $collectOutput =>
    string := STRCONC(fillerSpaces MAX(0,start - 1),op)
    $outputLines := [string, :$outputLines]
  PRINTEXP(op,$algebraOutputStream)
  TERPRI $algebraOutputStream

qTSub(u) ==
  subspan CADR u

qTSuper(u) ==
  superspan CADR u

qTWidth(u) ==
  2 + WIDTH CADR u

remWidth(x) ==
  atom x => x
  true => CONS( (atom first x => first x; true => CAAR x),
                MMAPCAR(function remWidth, rest x) )

subSub(u) ==
  height CDDR u

subSuper u ==
  superspan u.1

letWidth u ==
  5 + WIDTH u.1 + WIDTH u.2

sumoverlist(u) == +/[x for x in u]

sumWidth u ==
  WIDTH u.1 + sumWidthA CDDR u

sumWidthA u ==
  ^u => 0
  ( member(keyp absym first u,'(_+ _-)) => 5; true => 3) +
    WIDTH absym first u +
      sumWidthA rest u

superSubApp(u, x, y, di) ==
  a := first (u := rest u)
  b := first (u := rest u)
  c := first (u := KDR u) or '((NOTHING . 0))
  d := KAR   (u := KDR u) or '((NOTHING . 0))
  e := KADR  u            or '((NOTHING . 0))
  aox := MAX(wd := WIDTH d, we := WIDTH e)
  ar := superspan a
  ab := subspan a
  aw := WIDTH a
  di := APP(d, x + (aox - wd), 1 + ar + y + subspan d, di)
  di := APP(a, x + aox, y, di)
  di := APP(c, aox + aw + x, 1 + y + ar + subspan c, di)
  di := APP(e, x + (aox - we), y - 1 - MAX(superspan e, ab), di)
  di := APP(b, aox + aw + x, y - 1 - MAX(ab, superspan b), di)
  return di

stringer x ==
  STRINGP x => x
  EQ('_|, FETCHCHAR(s:= STRINGIMAGE x, 0)) =>
    RPLACSTR(s, 0, 1, "", nil, nil)
  s

superSubSub u ==
  a:= first (u:= rest u)
  b:= KAR (u := KDR u)
  e:= KAR KDR KDR KDR u
  return subspan a + MAX(height b, height e)

binomApp(u,x,y,d) ==
  [num,den] := rest u
  ysub := y - 1 - superspan den
  ysup := y + 1 + subspan num
  wden := WIDTH den
  wnum := WIDTH num
  w := MAX(wden,wnum)
  d := APP(den,x+1+ half(w - wden),ysub,d)
  d := APP(num,x+1+ half(w - wnum),ysup,d)
  hnum := height num
  hden := height den
  w := 1 + w
  for j in 0..(hnum - 1) repeat
    d := appChar(specialChar 'vbar,x,y + j,d)
    d := appChar(specialChar 'vbar,x + w,y + j,d)
  for j in 1..(hden - 1) repeat
    d := appChar(specialChar 'vbar,x,y - j,d)
    d := appChar(specialChar 'vbar,x + w,y - j,d)
  d := appChar(specialChar 'ulc,x,y + hnum,d)
  d := appChar(specialChar 'urc,x + w,y + hnum,d)
  d := appChar(specialChar 'llc,x,y - hden,d)
  d := appChar(specialChar 'lrc,x + w,y - hden,d)

binomSub u == height CADDR u
binomSuper u == height CADR u
binomWidth u == 2 + MAX(WIDTH CADR u, WIDTH CADDR u)

altSuperSubApp(u, x, y, di) ==
  a  := first (u := rest u)
  ar := superspan a
  ab := subspan a
  aw := WIDTH a
  di := APP(a, x, y, di)
  x  := x + aw

  sublist := everyNth(u := rest u, 2)
  suplist := everyNth(IFCDR u, 2)

  ysub := y - 1 - APPLY('MAX, [ab, :[superspan s for s in sublist]])
  ysup := y + 1 + APPLY('MAX, [ar, :[subspan   s for s in sublist]])
  for sub in sublist for sup in suplist repeat
      wsub := WIDTH sub
      wsup := WIDTH sup
      di := APP(sub, x, ysub, di)
      di := APP(sup, x, ysup, di)
      x := x + 1 + MAX(wsub, wsup)
  di

everyNth(l, n) ==
    [(e := l.0; for i in 1..n while l repeat l := rest l; e) while l]


altSuperSubSub u ==
  span := subspan CADR u
  sublist := everyNth(CDDR u, 2)
  for sub in sublist repeat
      h := height sub
      if h > span then span := h
  span

altSuperSubSuper u ==
  span := superspan CADR u
  suplist := everyNth(IFCDR CDDR u, 2)
  for sup in suplist repeat
      h := height sup
      if h > span then span := h
  span

altSuperSubWidth u ==
  w := WIDTH CADR u
  suplist := everyNth(IFCDR CDDR u, 2)
  sublist := everyNth(CDDR u, 2)
  for sup in suplist for sub in sublist repeat
      wsup := WIDTH sup
      wsub := WIDTH sub
      w := w + 1 + MAX(wsup, wsub)
  w

superSubWidth u ==
  a := first (u := rest u)
  b := first (u := rest u)
  c := first (u := KDR u) or '((NOTHING . 0))
  d := KAR   (u := KDR u) or '((NOTHING . 0))
  e := KADR  u            or '((NOTHING . 0))
  return MAX(WIDTH d, WIDTH e) + MAX(WIDTH b, WIDTH c) + WIDTH a

superSubSuper u ==
  a:= first (u := rest u)
  c:= KAR (u := KDR KDR u)
  d:= KADR u
  return superspan a + MAX(height c, height d)

suScWidth u ==
  WIDTH u.1 + aggwidth CDDR u

transcomparg(x) ==
  y := first x
  args := first _*NTH(STANDARGLIST, 1 + LENGTH y)
  repeat
    if true then
       null y => return(nil)
       (atom first y) and member(first y, FRLIS_*) =>
            conds := CONS(LIST('EQUAL1, first args, first y), conds)
            y := SUBST(first args, first y, y)
            x := SUBST(first args, first y, x)
       (first y = first args) => nil
       true => conds := CONS(LIST('EQUAL1, first args, first y), conds)
    y := rest y
    args := rest args
  conds :=
       null conds => rest CADR x
       ANDSIMP(CONS('AND, APPEND(REVERSEWOC conds,
                                         LIST(rest CADR x) ) ) )
  LIST((conds => conds; true => 1), CADR rest x)

vconcatapp(u, x, y, d) ==
  w := vConcatWidth u
  y := y + superspan u.1 + 1
  for a in rest u repeat
      y := y - superspan a - 1
      xoff := QUOTIENT(w - WIDTH a, 2)
      d := APP(a, x + xoff, y, d)
      y := y - subspan a
  d

binomialApp(u, x, y, d) ==
  [.,b,a] := u
  w := vConcatWidth u
  d := APP('"(",x,y,d)
  x := x + 1
  y1 := y - height a
  xoff := QUOTIENT(w - WIDTH a, 2)
  d := APP(a, x + xoff, y1, d)
  y2 := y + height b
  xoff := QUOTIENT(w - WIDTH b, 2)
  d := APP(b, x + xoff, y2, d)
  x := x + w
  APP('")",x,y,d)

vConcatSub u ==
  subspan u.1 + +/[height a for a in CDDR u]
vConcatSuper u ==
  superspan u.1
vConcatWidth u ==
  w := 0
  for a in rest u repeat if (wa := WIDTH a) > w then w := wa
  w
binomialSub u ==  height u.2 + 1

binomialSuper u == height u.1 + 1

binomialWidth u == 2 + MAX(WIDTH u.1, WIDTH u.2)

mathPrint u ==
  if ^$collectOutput then TERPRI $algebraOutputStream
  (u := STRINGP mathPrint1(mathPrintTran u, nil) =>
   PSTRING u; nil)

mathPrintTran u ==
  atom u => u
  true =>
    for x in tails u repeat
          RPLAC(first x, mathPrintTran first x)
    u

mathPrint1(x,fg) ==
  if fg and ^$collectOutput then TERPRI $algebraOutputStream
  maPrin x
  if fg and ^$collectOutput then TERPRI $algebraOutputStream

maPrin u ==
  null u => nil
-->
  if $runTestFlag or $mkTestFlag then
    $mkTestOutputStack := [COPY u, :$mkTestOutputStack]
  $highlightDelta := 0
  c := CATCH('outputFailure,charybdis(u, $MARGIN, $LINELENGTH))
  c ^= 'outputFailure => c
  sayKeyedMsg("S2IX0009",NIL)
  u is ['EQUATNUM,num,form] or u is [['EQUATNUM,:.],num,form] =>
    charybdis(['EQUATNUM,num], $MARGIN, $LINELENGTH)
    if ^$collectOutput then
      TERPRI $algebraOutputStream
      PRETTYPRINT(form,$algebraOutputStream)
    form
  if ^$collectOutput then PRETTYPRINT(u,$algebraOutputStream)
  nil