aboutsummaryrefslogtreecommitdiff
path: root/src/interp/i-output.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/i-output.boot.pamphlet')
-rw-r--r--src/interp/i-output.boot.pamphlet2467
1 files changed, 2467 insertions, 0 deletions
diff --git a/src/interp/i-output.boot.pamphlet b/src/interp/i-output.boot.pamphlet
new file mode 100644
index 00000000..bb0d87b1
--- /dev/null
+++ b/src/interp/i-output.boot.pamphlet
@@ -0,0 +1,2467 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/i-output.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{GCL\_log10\_bug}
+
+In some versions of GCL the LOG10 function returns improperly rounded values.
+The symptom is:
+\begin{verbatim}
+(24) -> [1000]
+ (24) [100]
+\end{verbatim}
+The common lisp failure can be shown with:
+\begin{verbatim}
+(25) -> )lisp (log10 1000)
+Value = 2.9999999999999996
+\end{verbatim}
+This previous boot code was:
+\begin{verbatim}
+ u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR LOG10 u
+\end{verbatim}
+and should be restored when the GCL bug is fixed.
+<<GCLlog10bug>>=
+ u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR ((LOG10 u) + 0.0000001)
+@
+\section{License}
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+--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
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($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))
+
+SETANDFILEQ($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
+ ])
+
+SETANDFILEQ($specialCharacters,$RTspecialCharacters)
+
+SETANDFILEQ($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(mkObjWrap(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 GET(key,"Nud") and null GET(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)]
+
+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
+<<GCLlog10bug>>
+ -- 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:= GET(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
+
+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 := (maxWidth-1)/ 2 + 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 + (maxWidth - botWidth)/2,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 + (maxWidth - topWidth)/2,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 CAR 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,(linelength-start-w)/2,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 GET(x,'Led) =>
+ d:= PNAME first GET(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(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+(w - wden)/2,ysub,d)
+ d := APP(num,x+1+(w - wnum)/2,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
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 06:26:27 +0000