diff options
Diffstat (limited to 'src/interp/i-output.boot')
| -rw-r--r-- | src/interp/i-output.boot | 2439 |
1 files changed, 2439 insertions, 0 deletions
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot new file mode 100644 index 00000000..055ddbc5 --- /dev/null +++ b/src/interp/i-output.boot @@ -0,0 +1,2439 @@ +-- 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(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 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 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+ 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 |