Edit detail for SandBoxIOutput revision 1 of 2

Example for debugging boot code

Insert lines:

      PRINT('"Debug:I'm here in putWidth. op=")
      PRINT(op)

(See below.)

To compile and load in Axiom source tree:

  )lisp (boottran::boottocl "src/interp/i-output2.boot")
  )lisp (load (compile-file "int/interp/i-output2.clisp"))

boot

-- 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.
--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:= GET(op,'PREFIXOP)) => GET(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 := GET(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 ; REVERSIP head ; REVERSIP is a function specific to CCL
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 ^GET(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:= GET(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:= GET(op,"INFIXOP") or '"," opWidth:= WIDTH opString [.,frst,:rst]:= e null rst => GET(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 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 == PRINT('"Debug:I'm here in putWidth. op=") atom u or u is [[.,:n],:.] and NUMBERP n => u op:= keyp u PRINT(op) --NUMBERP op => nil leftPrec:= getBindingPowerOf("left",u) rightPrec:= getBindingPowerOf("right",u) [firstEl,:l] := u interSpace:= GET(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:= GET(op,"PREFIXOP") => SIZE a 2+SIZE PNAME op a:= GET(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 (GET(op,"LED") or GET(op,"NUD")) => n:= GET(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 := GET(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) x = 'OVER => charyBinary(GET("/",'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) GET(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:= GET(keyp u,'INFIXOP) => d; opSrch(keyp u,OPLIST))) prnd(start,(d:= GET(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_ GET(CAAR u, 'SUBSPAN) ) => APPLX(GET(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_ GET(CAAR u, 'SUPERSPAN) ) => APPLX(GET(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

boot

 
   >> System error:
   invalid number of arguments: 1

   >> System error:
   failed to find the TRUENAME of 6082214352565232005-25px001.clisp:
  No such file or directory

putWidth((x**2)::OUTFORM)$Lisp

   There are no library operations named ** 
      Use HyperDoc Browse or issue
                                 )what op **
      to learn if there is any operation containing " ** " in its name.

   Cannot find a definition or applicable library operation named ** 
      with argument type(s) 
                                 Variable(x)
                               PositiveInteger

      Perhaps you should use "@" to indicate the required return type, 
      or "$" to specify which version of the function you need.

 )lisp (boot "src/interp/i-output2.boot")

to compile and load Boot code in one step.