diff --git a/changelog b/changelog index b5d9a3b..b64cfea 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090822 tpd src/axiom-website/patches.html 20090822.02.tpd.patch +20090822 tpd src/interp/Makefile move i-output.boot to i-output.lisp +20090822 tpd src/interp/i-output.lisp added, rewritten from i-output.boot +20090822 tpd src/interp/i-output.boot removed, rewritten to i-output.lisp 20090822 tpd src/axiom-website/patches.html 20090822.01.tpd.patch 20090822 tpd src/interp/Makefile move i-map.boot to i-map.lisp 20090822 tpd src/interp/i-map.lisp added, rewritten from i-map.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5cbdb18..275cb36 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1836,5 +1836,7 @@ i-intern.lisp rewrite from boot to lisp
i-funsel.lisp rewrite from boot to lisp
20090822.01.tpd.patch i-map.lisp rewrite from boot to lisp
+20090822.02.tpd.patch +i-output.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 64686c1..65db62a 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -431,7 +431,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ ${DOC}/intint.lisp.dvi ${DOC}/int-top.boot.dvi \ - ${DOC}/i-output.boot.dvi ${DOC}/i-resolv.boot.dvi \ + ${DOC}/i-resolv.boot.dvi \ ${DOC}/i-spec1.boot.dvi ${DOC}/i-spec2.boot.dvi \ ${DOC}/i-syscmd.boot.dvi ${DOC}/iterator.boot.dvi \ ${DOC}/i-toplev.boot.dvi ${DOC}/i-util.boot.dvi \ @@ -3271,47 +3271,27 @@ ${MID}/i-map.lisp: ${IN}/i-map.lisp.pamphlet @ -\subsection{i-output.boot} +\subsection{i-output.lisp} <>= -${OUT}/i-output.${O}: ${MID}/i-output.clisp - @ echo 306 making ${OUT}/i-output.${O} from ${MID}/i-output.clisp - @ (cd ${MID} ; \ +${OUT}/i-output.${O}: ${MID}/i-output.lisp + @ echo 136 making ${OUT}/i-output.${O} from ${MID}/i-output.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-output.clisp"' \ + echo '(progn (compile-file "${MID}/i-output.lisp"' \ ':output-file "${OUT}/i-output.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-output.clisp"' \ + echo '(progn (compile-file "${MID}/i-output.lisp"' \ ':output-file "${OUT}/i-output.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-output.clisp: ${IN}/i-output.boot.pamphlet - @ echo 307 making ${MID}/i-output.clisp \ - from ${IN}/i-output.boot.pamphlet +<>= +${MID}/i-output.lisp: ${IN}/i-output.lisp.pamphlet + @ echo 137 making ${MID}/i-output.lisp from \ + ${IN}/i-output.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-output.boot.pamphlet >i-output.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-output.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-output.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-output.boot ) - -@ -<>= -${DOC}/i-output.boot.dvi: ${IN}/i-output.boot.pamphlet - @echo 308 making ${DOC}/i-output.boot.dvi \ - from ${IN}/i-output.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-output.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-output.boot ; \ - rm -f ${DOC}/i-output.boot.pamphlet ; \ - rm -f ${DOC}/i-output.boot.tex ; \ - rm -f ${DOC}/i-output.boot ) + ${TANGLE} ${IN}/i-output.lisp.pamphlet >i-output.lisp ) @ @@ -6531,8 +6511,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-output.boot.pamphlet b/src/interp/i-output.boot.pamphlet deleted file mode 100644 index 3ca37ff..0000000 --- a/src/interp/i-output.boot.pamphlet +++ /dev/null @@ -1,2300 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-output.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - ---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 - -$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 = "/" => - $fractionDisplayType = 'horizontal => - op := 'SLASH - l is [a, b] => - a:= - ATOM(a) => a - ['PAREN, a] - b:= - ATOM(b) => b - ['PAREN, b] - [outputTran op, a, b] - BREAK() - 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 => - u = 0 => 1 - if (u < 1) then - negative := 1 - else - negative := 0 - DIGITS_-BY_-RADIX(u, 10) + negative - 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:= - 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 - -mathmlFormat expr == - mml := '(MathMLFormat) - mmlrep := '(String) - formatFn := getFunctionFromDomain("coerce",mml,[$OutputForm]) - displayFn := getFunctionFromDomain("display",mml,[mmlrep]) - SPADCALL(SPADCALL(expr,formatFn),displayFn) - TERPRI $mathmlOutputStream - FORCE_-OUTPUT $mathmlOutputStream - 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 - if $mathmlFormat then mathmlFormat 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 - if $mathmlFormat then mathmlFormat x - (FUNCTIONP(opOf domain)) and (not (SYMBOLP(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] 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 -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-output.lisp.pamphlet b/src/interp/i-output.lisp.pamphlet new file mode 100644 index 0000000..f7c03a9 --- /dev/null +++ b/src/interp/i-output.lisp.pamphlet @@ -0,0 +1,7365 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-output.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-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 +;$collectOutput := nil + +(SPADLET |$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) + +(DEFUN |specialChar| (|symbol|) + (PROG (|code|) + (RETURN + (COND + ((NULL (SPADLET |code| (IFCDR (ASSQ |symbol| |$specialCharacterAlist|)))) + (MAKESTRING "?")) + ((QUOTE T) + (ELT |$specialCharacters| |code|)))))) + +;rbrkSch() == PNAME specialChar 'rbrk + +(DEFUN |rbrkSch| NIL (PNAME (|specialChar| (QUOTE |rbrk|)))) + +;lbrkSch() == PNAME specialChar 'lbrk + +(DEFUN |lbrkSch| NIL (PNAME (|specialChar| (QUOTE |lbrk|)))) + +;quadSch() == PNAME specialChar 'quad + +(DEFUN |quadSch| NIL (PNAME (|specialChar| (QUOTE |quad|)))) + +;isBinaryInfix x == +; x in '(_= _+ _- _* _/ _*_* _^ "=" "+" "-" "*" "/" "**" "^") + +(DEFUN |isBinaryInfix| (|x|) + (|member| |x| (QUOTE (= + - * / ** ^ "=" "+" "-" "*" "/" "**" "^")))) + +;stringApp([.,u],x,y,d) == +; appChar(STRCONC($DoubleQuote,atom2String u,$DoubleQuote),x,y,d) + +(DEFUN |stringApp| (#0=#:G166074 |x| |y| |d|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (CADR #0#)) + (|appChar| + (STRCONC |$DoubleQuote| (|atom2String| |u|) |$DoubleQuote|) + |x| |y| |d|))))) + +;stringWidth u == +; u is [.,u] or THROW('outputFailure,'outputFailure) +; 2+#u + +(DEFUN |stringWidth| (|u|) + (PROG (|ISTMP#1|) + (RETURN + (PROGN + (OR + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) (QUOTE T))))) + (THROW (QUOTE |outputFailure|) (QUOTE |outputFailure|))) + (PLUS 2 (|#| |u|)))))) + +;obj2String o == +; atom o => +; STRINGP o => o +; o = " " => '" " +; o = ")" => '")" +; o = "(" => '"(" +; STRINGIMAGE o +; APPLY('STRCONC,[obj2String o' for o' in o]) + +(DEFUN |obj2String| (|o|) + (PROG NIL + (RETURN + (SEQ + (COND + ((ATOM |o|) + (COND + ((STRINGP |o|) |o|) + ((BOOT-EQUAL |o| (QUOTE | |)) (MAKESTRING " ")) + ((BOOT-EQUAL |o| (QUOTE |)|)) + (MAKESTRING ")")) + ((BOOT-EQUAL |o| (QUOTE |(|)) (MAKESTRING "(")) + ((QUOTE T) (STRINGIMAGE |o|)))) + ((QUOTE T) + (APPLY + (QUOTE STRCONC) + (PROG (#0=#:G166101) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166106 |o| (CDR #1#)) (|o'| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |o'| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|obj2String| |o'|) #0#)))))))))))))) + +;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) + +(DEFUN APP (|u| |x| |y| |d|) + (PROG (|op| |ISTMP#2| |a| |s| |ISTMP#1| |id| |fn| |d'|) + (RETURN + (COND + ((ATOM |u|) (|appChar| (|atom2String| |u|) |x| |y| |d|)) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |u|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) 'T))) + (SPADLET |s| (GETL |op| 'PREFIXOP))) + (COND + ((GETL |op| '|isSuffix|) + (|appChar| |s| (PLUS |x| (WIDTH |a|)) |y| + (APP |a| |x| |y| |d|))) + ('T + (APP |a| (PLUS |x| (|#| |s|)) |y| + (|appChar| |s| |x| |y| |d|))))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |id| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((SPADLET |fn| (GETL |id| 'APP)) + (FUNCALL |fn| |u| |x| |y| |d|)) + ((AND (NULL (NUMBERP |id|)) + (SPADLET |d'| (|appInfix| |u| |x| |y| |d|))) + |d'|) + ('T (|appelse| |u| |x| |y| |d|)))) + ('T (|appelse| |u| |x| |y| |d|)))))) + +;atom2String x == +; IDENTP x => PNAME x +; STRINGP x => x +; stringer x + +(DEFUN |atom2String| (|x|) + (COND + ((IDENTP |x|) (PNAME |x|)) + ((STRINGP |x|) |x|) + ((QUOTE T) (|stringer| |x|)))) + +@ +\begin{verbatim} +General convention in the ``app...'' functions: +Added from an attempt to fix bugs by JHD: 2 Aug 89 +The arguments are: +\begin{itemize} +\item what has to be printed +\item - x - is the horizontal distance along the page at which to start +\item - y - is some vertical hacking control +\item - d - is the "layout" so far +\end{itemize} +these functions return an updated ``layout so far'' in general +\end{verbatim} +<<*>>= +;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," ")]])) + +(DEFUN |appChar| (|string| |x| |y| |d|) + (PROG (|line| |bumpDeltaIfTrue| |shiftedX| |n|) + (RETURN + (PROGN + (COND ((CHARP |string|) (SPADLET |string| (PNAME |string|)))) + (COND + ((SPADLET |line| (LASSOC |y| |d|)) + (COND + ((AND + (EQL (MAXINDEX |string|) 1) + (BOOT-EQUAL (|char| (ELT |string| 0)) (QUOTE %))) + (COND + ((BOOT-EQUAL (ELT |string| 1) (QUOTE |b|)) + (SPADLET |bumpDeltaIfTrue| (QUOTE T)) + (SETELT |string| 0 (EBCDIC 29)) + (SETELT |string| 1 (EBCDIC 200))) + ((BOOT-EQUAL (ELT |string| 1) (QUOTE |d|)) + (SPADLET |bumpDeltaIfTrue| (QUOTE T)) + (SETELT |string| 0 (EBCDIC 29)) + (SETELT |string| 1 (EBCDIC 65)))))) + (SPADLET |shiftedX| + (COND + ((EQL |y| 0) (PLUS |x| |$highlightDelta|)) + ((QUOTE T) |x|))) + (RPLACSTR |line| |shiftedX| (SPADLET |n| (|#| |string|)) |string| 0 |n|) + (COND + ((BOOT-EQUAL |bumpDeltaIfTrue| (QUOTE T)) + (SPADLET |$highlightDelta| (PLUS |$highlightDelta| 1)))) |d|) + ((QUOTE T) + (|appChar| |string| |x| |y| + (NCONC |d| + (CONS + (CONS |y| + (GETFULLSTR (PLUS (PLUS 10 $LINELENGTH) $MARGIN) (QUOTE | |))) + NIL))))))))) + +;print(x,domain) == +; dom:= devaluate domain +; $InteractiveMode: local:= true +; $dontDisplayEquatnum: local:= true +; output(x,dom) + +(DEFUN |print| (|x| |domain|) + (PROG (|$InteractiveMode| |$dontDisplayEquatnum| |dom|) + (DECLARE (SPECIAL |$InteractiveMode| |$dontDisplayEquatnum|)) + (RETURN + (PROGN + (SPADLET |dom| (|devaluate| |domain|)) + (SPADLET |$InteractiveMode| (QUOTE T)) + (SPADLET |$dontDisplayEquatnum| (QUOTE T)) + (|output| |x| |dom|))))) + +;mathprintWithNumber x == +; x:= outputTran x +; maprin +; $IOindex => ['EQUATNUM,$IOindex,x] +; x + +(DEFUN |mathprintWithNumber| (|x|) + (PROGN + (SPADLET |x| (|outputTran| |x|)) + (|maprin| + (COND + (|$IOindex| (CONS (QUOTE EQUATNUM) (CONS |$IOindex| (CONS |x| NIL)))) + ((QUOTE T) |x|))))) + +;mathprint x == +; x := outputTran x +; $saturn => texFormat1 x +; maprin x + +(DEFUN |mathprint| (|x|) + (PROGN + (SPADLET |x| (|outputTran| |x|)) + (COND (|$saturn| (|texFormat1| |x|)) ((QUOTE T) (|maprin| |x|))))) + +;sayMath u == +; for x in u repeat acc:= concat(acc,linearFormatName x) +; sayALGEBRA acc + +(DEFUN |sayMath| (|u|) + (PROG (|acc|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G166189 |u| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (SPADLET |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 = "/" => +; $fractionDisplayType = 'horizontal => +; op := 'SLASH +; l is [a, b] => +; a:= +; ATOM(a) => a +; ['PAREN, a] +; b:= +; ATOM(b) => b +; ['PAREN, b] +; [outputTran op, a, b] +; BREAK() +; 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] + +(DEFUN |outputTran| (|x|) + (PROG (|mode| |var| |body| |vars| |d| |m| |e| |domain| |ISTMP#3| + |ISTMP#4| |ISTMP#5| |y| |ISTMP#6| |z| |float| |f| |o| + |LETTMP#1| |a'| |b'| |fun| |targ| |targ'| |c| |foo1| + |op'| |foo2| |foo3| |foo4| |l| |ll| |op| |a| |b| + |ISTMP#1| |u| |ISTMP#2| |pred|) + (RETURN + (SEQ (COND + ((|member| |x| '("failed" "nil" "prime" "sqfr" "irred")) + (STRCONC (MAKESTRING "\"") |x| (MAKESTRING "\""))) + ((STRINGP |x|) |x|) + ((VECP |x|) + (|outputTran| + (CONS 'BRACKET + (CONS (CONS 'AGGLST + (PROG (G166608) + (SPADLET G166608 NIL) + (RETURN + (DO + ((G166613 (MAXINDEX |x|)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166613) + (NREVERSE0 G166608)) + (SEQ + (EXIT + (SETQ G166608 + (CONS (ELT |x| |i|) + G166608)))))))) + NIL)))) + ((NUMBERP |x|) + (COND + ((MINUSP |x|) (CONS '- (CONS (MINUS |x|) NIL))) + ('T |x|))) + ((ATOM |x|) + (COND + ((BOOT-EQUAL |x| |$EmptyMode|) (|specialChar| '|quad|)) + ('T |x|))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |c| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |mode| (QCAR |ISTMP#2|)) + 'T))))) + (|member| |c| '(|pretend| |:| |::| @))) + (SPADLET |var| (|outputTran| |var|)) + (COND + ((PAIRP |var|) + (SPADLET |var| (CONS 'PAREN (CONS |var| NIL))))) + (CONS 'CONCATB + (CONS |var| + (CONS |c| + (CONS (|obj2String| + (|prefix2String| |mode|)) + NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ADEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |vars| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (SPADLET |vars| + (COND + ((AND (PAIRP |vars|) (EQ (QCDR |vars|) NIL) + (PROGN (SPADLET |x| (QCAR |vars|)) 'T)) + |x|) + ('T (CONS '|Tuple| |vars|)))) + (|outputTran| + (CONS '+-> (CONS |vars| (CONS |body| NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MATRIX) + (PROGN (SPADLET |m| (QCDR |x|)) 'T)) + (|outputTranMatrix| |m|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|matrix|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|construct|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T))))))) + (PAIRP |c|) (EQ (QCAR |c|) 'COLLECT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |c|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |d| (QCAR |ISTMP#2|)) + (SPADLET |m| (QCDR |ISTMP#2|)) + 'T) + (PROGN (SPADLET |m| (NREVERSE |m|)) 'T))) + (PAIRP |d|) (EQ (QCAR |d|) '|construct|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |d|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |e| (QCAR |ISTMP#1|)) 'T))) + (PAIRP |e|) (EQ (QCAR |e|) 'COLLECT)) + (|outputTran| + (CONS 'COLLECT (APPEND |m| (CONS |e| NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LIST) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (|outputTran| + (CONS 'BRACKET (CONS (CONS 'AGGLST |l|) NIL)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MAP) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (|outputMapTran| |l|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|brace|) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (CONS 'BRACE + (CONS (CONS 'AGGLST + (PROG (G166621) + (SPADLET G166621 NIL) + (RETURN + (DO + ((G166626 |l| (CDR G166626)) + (|y| NIL)) + ((OR (ATOM G166626) + (PROGN + (SETQ |y| (CAR G166626)) + NIL)) + (NREVERSE0 G166621)) + (SEQ + (EXIT + (SETQ G166621 + (CONS (|outputTran| |y|) + G166621)))))))) + NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|return|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) 'T)))) + (CONS '|return| (CONS (|outputTran| |l|) NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|return|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (CONS '|return| (|outputTran| |l|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|construct|) + (PROGN (SPADLET |l| (QCDR |x|)) 'T)) + (CONS 'BRACKET + (CONS (CONS 'AGGLST + (PROG (G166636) + (SPADLET G166636 NIL) + (RETURN + (DO + ((G166641 |l| (CDR G166641)) + (|y| NIL)) + ((OR (ATOM G166641) + (PROGN + (SETQ |y| (CAR G166641)) + NIL)) + (NREVERSE0 G166636)) + (SEQ + (EXIT + (SETQ G166636 + (CONS (|outputTran| |y|) + G166636)))))))) + NIL))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|$elt|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |domain| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (EQ (QCAR |ISTMP#3|) '|float|))))))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |x|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) NIL) + (PROGN + (SPADLET |z| (QCAR |ISTMP#6|)) + 'T))))))) + (OR (BOOT-EQUAL |domain| |$DoubleFloat|) + (AND (PAIRP |domain|) (EQ (QCDR |domain|) NIL) + (EQ (QCAR |domain|) '|Float|))) + (INTEGERP |x|) (INTEGERP |y|) (INTEGERP |z|) + (> |z| 0) + (SPADLET |float| + (|getFunctionFromDomain| '|float| |domain| + (CONS |$Integer| + (CONS |$Integer| + (CONS |$PositiveInteger| NIL)))))) + (SPADLET |f| (SPADCALL |x| |y| |z| |float|)) + (SPADLET |o| + (|coerceInteractive| (|mkObjWrap| |f| |domain|) + '(|OutputForm|))) + (|objValUnwrap| |o|)) + ('T (SPADLET |LETTMP#1| (|flattenOps| |x|)) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |l| (CDR |LETTMP#1|)) + (COND + ((STRINGP |op|) (SPADLET |op| (INTERN |op|)) + (SPADLET |x| (CONS |op| |l|)))) + (COND + ((BOOT-EQUAL |op| 'LAMBDA-CLOSURE) '|Closure|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|break|)) '|break|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEGMENT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |a'| (|outputTran| |a|)) + (COND + ((LISTP |a'|) + (SPADLET |a'| (CONS 'PAREN (CONS |a'| NIL))))) + (CONS 'SEGMENT (CONS |a'| NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEGMENT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |a'| (|outputTran| |a|)) + (SPADLET |b'| (|outputTran| |b|)) + (COND + ((LISTP |a'|) + (SPADLET |a'| (CONS 'PAREN (CONS |a'| NIL))))) + (COND + ((LISTP |b'|) + (SPADLET |b'| (CONS 'PAREN (CONS |b'| NIL))))) + (CONS 'SEGMENT (CONS |a'| (CONS |b'| NIL)))) + ((OR (AND (PAIRP |op|) (EQ (QCAR |op|) '|$elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |targ| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |fun| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (NULL |$InteractiveMode|) (PAIRP |op|) + (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |targ| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |fun| (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |targ'| + (|obj2String| (|prefix2String| |targ|))) + (COND + ((EQL 2 (|#| |targ|)) + (SPADLET |targ'| (CONS 'PAREN (CONS |targ'| NIL))))) + (CONS 'CONCAT + (CONS (|outputTran| (CONS |fun| |l|)) + (CONS (MAKESTRING "$") (CONS |targ'| NIL))))) + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) '|$elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |targ| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (NULL |$InteractiveMode|) (PAIRP |x|) + (EQ (QCAR |x|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |targ| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |targ'| + (|obj2String| (|prefix2String| |targ|))) + (COND + ((EQL 2 (|#| |targ|)) + (SPADLET |targ'| (CONS 'PAREN (CONS |targ'| NIL))))) + (CONS 'CONCAT + (CONS (|outputTran| |c|) + (CONS (MAKESTRING "$") (CONS |targ'| NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |a| (|outputTran| |a|)) + (SPADLET |b| (|outputTran| |b|)) + (COND + ((INTEGERP |b|) + (COND + ((MINUSP |b|) + (CONS '+ + (CONS |a| (CONS (SPADDIFFERENCE |b|) NIL)))) + ('T + (CONS '+ + (CONS |a| + (CONS (CONS '- (CONS |b| NIL)) NIL)))))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#1|)) + 'T)))) + (CONS '+ (CONS |a| (CONS |c| NIL)))) + ('T + (CONS '+ + (CONS |a| + (CONS (CONS '- (CONS |b| NIL)) NIL)))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '**) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) '"%e") + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |foo1| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |foo1|) (EQUAL (QCAR |foo1|) '"/") + (PROGN + (SPADLET |ISTMP#1| (QCDR |foo1|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |foo2| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |foo3| (QCAR |ISTMP#2|)) + 'T))))) + (INTEGERP |foo3|) (PAIRP |foo2|) + (EQ (QCAR |foo2|) '|log|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |foo2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |foo4| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((EQL |foo3| 2) + (CONS 'ROOT (CONS (|outputTran| |foo4|) NIL))) + ('T + (CONS 'ROOT + (CONS (|outputTran| |foo4|) + (CONS (|outputTran| |foo3|) NIL)))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '**) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) '"%e") + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |foo1| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |foo1|) + (PROGN + (SPADLET |op'| (QCAR |foo1|)) + (SPADLET |ISTMP#1| (QCDR |foo1|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |foo2| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |foo3| (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |op'| (MAKESTRING "*")) + (OR (AND (PAIRP |foo3|) (EQ (QCAR |foo3|) '|log|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |foo3|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |foo4| + (QCAR |ISTMP#1|)) + 'T)))) + (AND (PAIRP |foo2|) (EQ (QCAR |foo2|) '|log|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |foo2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |foo4| + (QCAR |ISTMP#1|)) + 'T)))))) + (COND + ((AND (PAIRP |foo3|) (EQ (QCAR |foo3|) '|log|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |foo3|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |foo4| (QCAR |ISTMP#1|)) + 'T)))) + (CONS '** + (CONS (|outputTran| |foo4|) + (CONS (|outputTran| |foo2|) NIL)))) + ('T (SPADLET |foo4| (CADR |foo2|)) + (CONS '** + (CONS (|outputTran| |foo4|) + (CONS (|outputTran| |foo3|) NIL)))))) + ((BOOT-EQUAL |op| 'IF) (|outputTranIf| |x|)) + ((BOOT-EQUAL |op| 'COLLECT) (|outputTranCollect| |x|)) + ((BOOT-EQUAL |op| 'REDUCE) (|outputTranReduce| |x|)) + ((BOOT-EQUAL |op| 'REPEAT) (|outputTranRepeat| |x|)) + ((BOOT-EQUAL |op| 'SEQ) (|outputTranSEQ| |x|)) + ((|member| |op| '(|cons| |nconc|)) + (|outputConstructTran| |x|)) + ('T + (SPADLET |l| + (PROG (G166651) + (SPADLET G166651 NIL) + (RETURN + (DO ((G166656 |l| (CDR G166656)) + (|y| NIL)) + ((OR (ATOM G166656) + (PROGN + (SETQ |y| (CAR G166656)) + NIL)) + (NREVERSE0 G166651)) + (SEQ (EXIT + (SETQ G166651 + (CONS (|outputTran| |y|) + G166651)))))))) + (COND + ((BOOT-EQUAL |op| '*) + (COND + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |a| (QCAR |l|)) 'T)) + (|outputTran| |a|)) + ((AND (PAIRP |l|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |l|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '-) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T))))) + (PROGN (SPADLET |b| (QCDR |l|)) 'T)) + (COND + ((EQL |a| 1) + (|outputTran| + (CONS '- (CONS (CONS |op| |b|) NIL)))) + ('T + (|outputTran| + (CONS '- + (CONS (CONS |op| (CONS |a| |b|)) + NIL)))))) + ('T + (CONS |op| + (PROG (G166662) + (SPADLET G166662 NIL) + (RETURN + (DO ((G166669 |l| (CDR G166669)) + (|ss| NIL)) + ((OR (ATOM G166669) + (PROGN + (SETQ |ss| (CAR G166669)) + NIL)) + G166662) + (SEQ + (EXIT + (SETQ G166662 + (APPEND G166662 + (COND + ((AND (PAIRP |ss|) + (EQ (QCAR |ss|) '*) + (PROGN + (SPADLET |ll| (QCDR |ss|)) + 'T)) + |ll|) + ('T (CONS |ss| NIL)))))))))))))) + ((BOOT-EQUAL |op| '+) + (COND + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |a| (QCAR |l|)) 'T)) + (|outputTran| |a|)) + ('T + (CONS |op| + (PROG (G166675) + (SPADLET G166675 NIL) + (RETURN + (DO ((G166682 |l| (CDR G166682)) + (|ss| NIL)) + ((OR (ATOM G166682) + (PROGN + (SETQ |ss| (CAR G166682)) + NIL)) + G166675) + (SEQ + (EXIT + (SETQ G166675 + (APPEND G166675 + (COND + ((AND (PAIRP |ss|) + (EQ (QCAR |ss|) '+) + (PROGN + (SPADLET |ll| (QCDR |ss|)) + 'T)) + |ll|) + ('T (CONS |ss| NIL)))))))))))))) + ((BOOT-EQUAL |op| '/) + (COND + ((BOOT-EQUAL |$fractionDisplayType| + '|horizontal|) + (SPADLET |op| 'SLASH) + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |a| (QCAR |l|)) + (SPADLET |ISTMP#1| (QCDR |l|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |a| + (COND + ((ATOM |a|) |a|) + ('T (CONS 'PAREN (CONS |a| NIL))))) + (SPADLET |b| + (COND + ((ATOM |b|) |b|) + ('T (CONS 'PAREN (CONS |b| NIL))))) + (CONS (|outputTran| |op|) + (CONS |a| (CONS |b| NIL)))) + ('T (BREAK)))) + ('T (SPADLET |op| 'OVER) + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |l|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '-) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#2|)) + 'T))))) + (PROGN (SPADLET |b| (QCDR |l|)) 'T)) + (|outputTran| + (CONS '- + (CONS (CONS |op| (CONS |a| |b|)) + NIL)))) + ('T (CONS (|outputTran| |op|) |l|)))))) + ((AND (BOOT-EQUAL |op| '|\||) (PAIRP |l|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |l|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Tuple|) + (PROGN + (SPADLET |u| (QCDR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |l|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |pred| (QCAR |ISTMP#2|)) + 'T)))) + (CONS 'PAREN + (CONS (CONS '|\|| + (CONS (CONS 'AGGLST |l|) + (CONS |pred| NIL))) + NIL))) + ((BOOT-EQUAL |op| '|Tuple|) + (CONS 'PAREN (CONS (CONS 'AGGLST |l|) NIL))) + ((BOOT-EQUAL |op| 'LISTOF) (CONS 'AGGLST |l|)) + ((AND (IDENTP |op|) (NULL (|member| |op| '(* **))) + (BOOT-EQUAL (|char| '*) (ELT (PNAME |op|) 0))) + (|mkSuperSub| |op| |l|)) + ('T (CONS (|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 + +(DEFUN |flattenOps| (|l|) + (PROG (|op| |args|) + (RETURN + (PROGN + (SPADLET |op| (CAR |l|)) + (SPADLET |args| (CDR |l|)) + (COND + ((|member| |op| + (CONS "+" (CONS "*" (CONS (QUOTE +) (CONS (QUOTE *) NIL))))) + (CONS |op| (|checkArgs| |op| |args|))) + ((QUOTE T) |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 + +(DEFUN |checkArgs| (|op| |tail|) + (PROG (|term| |head|) + (RETURN + (SEQ + (PROGN + (SPADLET |head| NIL) + (DO () + ((NULL |tail|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |term| (CAR |tail|)) + (COND + ((ATOM |term|) + (SPADLET |head| (CONS |term| |head|)) + (SPADLET |tail| (CDR |tail|))) + ((NULL (LISTP |term|)) + (SPADLET |head| (CONS |term| |head|)) + (SPADLET |tail| (CDR |tail|))) + ((BOOT-EQUAL |op| (CAR |term|)) + (SPADLET |tail| (APPEND (CDR |term|) (CDR |tail|)))) + ((QUOTE T) + (SPADLET |head| (CONS |term| |head|)) + (SPADLET |tail| (CDR |tail|)))))))) + (REVERSE |head|)))))) + +;; REVERSIP head + +NIL + +;; REVERSIP is a function specific to CCL + +NIL + +;outputTranSEQ ['SEQ,:l,exitform] == +; if exitform is ['exit,.,a] then exitform := a +; ['SC,:[outputTran x for x in l],outputTran exitform] + +(DEFUN |outputTranSEQ| (#0=G166882) + (PROG (|LETTMP#1| |l| |ISTMP#1| |ISTMP#2| |a| |exitform|) + (RETURN + (SEQ + (PROGN + (SPADLET |LETTMP#1| (REVERSE (CDR #0#))) + (SPADLET |exitform| (CAR |LETTMP#1|)) + (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) + (COND + ((AND (PAIRP |exitform|) + (EQ (QCAR |exitform|) (QUOTE |exit|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |exitform|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |exitform| |a|))) + (CONS (QUOTE SC) + (APPEND + (PROG (#1=G166903) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=G166908 |l| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) (NREVERSE0 #1#)) + (SEQ (EXIT (SETQ #1# (CONS (|outputTran| |x|) #1#))))))) + (CONS (|outputTran| |exitform|) NIL)))))))) + +;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']]] + +(DEFUN |outputTranIf| (#0=G166926) + (PROG (|x| |y| |z| |y'| |z'|) + (RETURN + (PROGN + (SPADLET |x| (CADR #0#)) + (SPADLET |y| (CADDR #0#)) + (SPADLET |z| (CADDDR #0#)) + (COND + ((BOOT-EQUAL |y| (QUOTE |noBranch|)) + (CONS (QUOTE CONCATB) + (CONS (QUOTE |if|) + (CONS + (CONS (QUOTE CONCATB) + (CONS (QUOTE |not|) (CONS (|outputTran| |x|) NIL))) + (CONS (QUOTE |then|) + (CONS (|outputTran| |z|) NIL)))))) + ((BOOT-EQUAL |z| (QUOTE |noBranch|)) + (CONS (QUOTE CONCATB) + (CONS (QUOTE |if|) + (CONS + (|outputTran| |x|) + (CONS (QUOTE |then|) (CONS (|outputTran| |y|) NIL)))))) + ((QUOTE T) + (SPADLET |y'| (|outputTran| |y|)) + (SPADLET |z'| (|outputTran| |z|)) + (CONS (QUOTE CONCATB) + (CONS (QUOTE |if|) + (CONS (|outputTran| |x|) + (CONS + (CONS (QUOTE SC) + (CONS + (CONS (QUOTE CONCATB) (CONS (QUOTE |then|) (CONS |y'| NIL))) + (CONS + (CONS (QUOTE CONCATB) (CONS (QUOTE |else|) (CONS |z'| NIL))) + NIL))) + NIL)))))))))) + +;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) + +(DEFUN |outputMapTran| (|l|) + (PROG (|$linearFormatScripts| |alias|) + (DECLARE (SPECIAL |$linearFormatScripts|)) + (RETURN + (SEQ + (COND + ((NULL |l|) NIL) + ((QUOTE T) + (SPADLET |$linearFormatScripts| (QUOTE T)) + (SPADLET |alias| (|get| |$op| (QUOTE |alias|) |$InteractiveFrame|)) + (COND + ((CDR |l|) + (CONS (QUOTE SC) + (PROG (#0=G166950) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=G166955 |l| (CDR #1#)) (|ll| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |ll| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|outputMapTran0| |ll| |alias|) #0#))))))))) + ((QUOTE T) + (|outputMapTran0| (CAR |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'] + +(DEFUN |outputMapTran0| (|argDef| |alias|) + (PROG (|arg| |def| |LETTMP#1| |def'| |arg'|) + (RETURN + (PROGN + (SPADLET |arg| (CAR |argDef|)) + (SPADLET |def| (CDR |argDef|)) + (SPADLET |LETTMP#1| (|simplifyMapPattern| |argDef| |alias|)) + (SPADLET |arg'| (CAR |LETTMP#1|)) + (SPADLET |def'| (CDR |LETTMP#1|)) + (SPADLET |arg'| (|outputTran| |arg'|)) + (COND ((NULL |arg'|) (SPADLET |arg'| (MAKESTRING "()")))) + (CONS (QUOTE CONCATB) + (CONS |$op| + (CONS + (|outputTran| |arg'|) + (CONS (QUOTE ==) (CONS (|outputTran| |def'|) NIL))))))))) + +;outputTranReduce ['REDUCE,op,.,body] == +; ['CONCAT,op,"/",outputTran body] + +(DEFUN |outputTranReduce| (#0=G166987) + (PROG (|op| |body|) + (RETURN + (PROGN + (SPADLET |op| (CADR #0#)) + (SPADLET |body| (CADDDR #0#)) + (CONS (QUOTE CONCAT) + (CONS |op| (CONS (QUOTE /) (CONS (|outputTran| |body|) NIL)))))))) + +;outputTranRepeat ["REPEAT",:itl,body] == +; body' := outputTran body +; itl => +; itlist:= outputTranIteration itl +; ['CONCATB,itlist,'repeat,body'] +; ['CONCATB,'repeat,body'] + +(DEFUN |outputTranRepeat| (#0=G167003) + (PROG (|LETTMP#1| |body| |itl| |body'| |itlist|) + (RETURN + (PROGN + (COND ((EQ (CAR #0#) (QUOTE REPEAT)) (CAR #0#))) + (SPADLET |LETTMP#1| (REVERSE (CDR #0#))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |body'| (|outputTran| |body|)) + (COND + (|itl| + (SPADLET |itlist| (|outputTranIteration| |itl|)) + (CONS (QUOTE CONCATB) + (CONS |itlist| (CONS (QUOTE |repeat|) (CONS |body'| NIL))))) + ((QUOTE T) + (CONS (QUOTE CONCATB) (CONS (QUOTE |repeat|) (CONS |body'| NIL))))))))) + +;outputTranCollect [.,:itl,body] == +; itlist:= outputTranIteration itl +; ['BRACKET,['CONCATB,outputTran body,itlist]] + +(DEFUN |outputTranCollect| (#0=G167025) + (PROG (|LETTMP#1| |body| |itl| |itlist|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (REVERSE (CDR #0#))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |itlist| (|outputTranIteration| |itl|)) + (CONS (QUOTE BRACKET) + (CONS + (CONS (QUOTE CONCATB) (CONS (|outputTran| |body|) (CONS |itlist| NIL))) + NIL)))))) + +;outputTranIteration itl == +; null rest itl => outputTranIterate first itl +; ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl] + +(DEFUN |outputTranIteration| (|itl|) + (COND + ((NULL (CDR |itl|)) (|outputTranIterate| (CAR |itl|))) + ((QUOTE T) + (CONS (QUOTE CONCATB) + (CONS + (|outputTranIterate| (CAR |itl|)) + (CONS (|outputTranIteration| (CDR |itl|)) NIL)))))) + +;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]]) + +(DEFUN |outputTranIterate| (|x|) + (PROG (|init| |ISTMP#3| |step| |final| |init'| |final'| |n| |ISTMP#2| + |s| |ISTMP#1| |p| |op|) + (RETURN + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE STEP)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |init| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |final| (QCDR |ISTMP#3|)) + (QUOTE T))))))))) + (SPADLET |init'| (|outputTran| |init|)) + (COND + ((LISTP |init|) + (SPADLET |init'| (CONS (QUOTE PAREN) (CONS |init'| NIL))))) + (SPADLET |final'| + (COND + (|final| + (COND + ((LISTP (CAR |final|)) + (CONS + (CONS (QUOTE PAREN) (CONS (|outputTran| (CAR |final|)) NIL)) + NIL)) + ((QUOTE T) (CONS (|outputTran| (CAR |final|)) NIL)))) + ((QUOTE T) NIL))) + (CONS (QUOTE STEP) + (CONS (|outputTran| |n|) + (CONS |init'| (CONS (|outputTran| |step|) |final'|))))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IN)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |s| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (CONS (QUOTE IN) (CONS (|outputTran| |n|) (CONS (|outputTran| |s|) NIL)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) (QUOTE T)))) + (|member| |op| (QUOTE (|\|| UNTIL WHILE)))) + (SPADLET |op| (DOWNCASE |op|)) + (CONS (QUOTE CONCATB) (CONS |op| (CONS (|outputTran| |p|) NIL)))) + ((QUOTE T) + (|throwKeyedMsg| (QUOTE S2IX0008) + (CONS (QUOTE |outputTranIterate|) + (CONS (CONS "illegal iterate: " (CONS |x| NIL)) NIL)))))))) + +;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] + +(DEFUN |outputConstructTran| (|x|) + (PROG (|op| |ISTMP#2| |a| |b| |ISTMP#1| |c| |aPart| |l|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |a| (|outputTran| |a|)) + (SPADLET |b| (|outputTran| |b|)) + (COND + ((BOOT-EQUAL |op| (QUOTE |cons|)) + (COND + ((AND (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE |construct|)) + (PROGN (SPADLET |l| (QCDR |b|)) (QUOTE T))) + (CONS (QUOTE |construct|) (CONS |a| |l|))) + ((QUOTE T) + (CONS (QUOTE BRACKET) + (CONS + (CONS (QUOTE AGGLST) + (CONS |a| (CONS (CONS (QUOTE |:|) (CONS |b| NIL)) NIL))) + NIL))))) + ((BOOT-EQUAL |op| (QUOTE |nconc|)) + (SPADLET |aPart| + (COND + ((AND (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |construct|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |c|) + (EQ (QCAR |c|) (QUOTE SEGMENT))) + |c|) + ((QUOTE T) + (CONS (QUOTE |:|) (CONS |a| NIL))))) + (COND + ((AND (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE |construct|)) + (PROGN (SPADLET |l| (QCDR |b|)) (QUOTE T))) + (CONS (QUOTE |construct|) (CONS |aPart| |l|))) + ((QUOTE T) + (CONS (QUOTE BRACKET) + (CONS + (CONS (QUOTE AGGLST) + (CONS |aPart| (CONS (CONS (QUOTE |:|) (CONS |b| NIL)) NIL))) + NIL))))) + ((QUOTE T) (CONS |op| (CONS |a| (CONS |b| NIL)))))) + ((ATOM |x|) |x|) + ((QUOTE T) + (CONS (|outputTran| (CAR |x|)) (|outputConstructTran| (CDR |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]] + +(DEFUN |outputTranMatrix,outtranRow| (|x|) + (PROG NIL + (RETURN + (SEQ + (IF (NULL (VECP |x|)) + (EXIT + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "outputTranMatrix" + (CONS "improper internal form for matrix found in output routines" + NIL))))) + (EXIT + (CONS (QUOTE ROW) + (PROG (#0=G167193) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=G167198 (MAXINDEX |x|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|outputTran| (ELT |x| |i|)) #0#))))))))))))) + +(DEFUN |outputTranMatrix| (|x|) + (PROG NIL + (RETURN + (SEQ + (COND + ((NULL (VECP |x|)) (CONS (QUOTE MATRIX) |x|)) + ((QUOTE T) + (CONS (QUOTE MATRIX) + (CONS NIL + (PROG (#0=G167212) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=G167217 (MAXINDEX |x|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (|outputTranMatrix,outtranRow| (ELT |x| |i|)) + #0#))))))))))))))) + +;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 + +(DEFUN |mkSuperSub| (|op| |argl|) + (PROG (|s| |maxIndex| |d| |indexList| |cleanOp| |subPart| |l| |this| + |scripts| |superSubPart| |superSub|) + (RETURN + (SEQ + (COND + (|$linearFormatScripts| (|linearFormatForm| |op| |argl|)) + ((QUOTE T) + (SPADLET |s| (PNAME |op|)) + (SPADLET |indexList| + (PROG (#0=G167234) + (SPADLET #0# NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((NULL (DIGITP (SPADLET |d| (ELT |s| (SPADLET |maxIndex| |i|))))) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (PARSE-INTEGER (PNAME |d|)) #0#)))))))) + (SPADLET |cleanOp| + (INTERN + (PROG (#1=G167243) + (SPADLET #1# "") + (RETURN + (DO ((#2=G167248 (MAXINDEX |s|)) (|i| |maxIndex| (+ |i| 1))) + ((> |i| #2#) #1#) + (SEQ (EXIT (SETQ #1# (STRCONC #1# (PNAME (ELT |s| |i|))))))))))) + (COND + ((EQL (|#| |indexList|) 2) + (SPADLET |subPart| + (CONS (QUOTE SUB) (CONS |cleanOp| (TAKE (ELT |indexList| 1) |argl|)))) + (COND + ((SPADLET |l| (DROP (ELT |indexList| 1) |argl|)) (CONS |subPart| |l|)) + ((QUOTE T) |subPart|))) + ((QUOTE T) + (SPADLET |superSubPart| NIL) + (DO ((#3=G167260 (CDR |indexList|) (CDR #3#)) (|i| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |i| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |scripts| + (PROGN + (SPADLET |this| (TAKE |i| |argl|)) + (SPADLET |argl| (DROP |i| |argl|)) + (COND + ((EQL |i| 0) (CONS (QUOTE AGGLST) NIL)) + ((EQL |i| 1) (CAR |this|)) + ((QUOTE T) (CONS (QUOTE AGGLST) |this|))))) + (SPADLET |superSubPart| (CONS |scripts| |superSubPart|)))))) + (SPADLET |superSub| + (CONS (QUOTE SUPERSUB) (CONS |cleanOp| (REVERSE |superSubPart|)))) + (COND + (|argl| (CONS |superSub| |argl|)) + ((QUOTE T) |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 + +(DEFUN |timesApp| (|u| |x| |y| |d|) + (PROG (|rightPrec| |op| |LETTMP#1| |wasSimple| |wasQuotient| |wasNumber| + |lastOp| |firstTime|) + (RETURN + (SEQ + (PROGN + (SPADLET |rightPrec| + (|getOpBindingPower| (QUOTE *) (QUOTE |Led|) (QUOTE |right|))) + (SPADLET |firstTime| (QUOTE T)) + (DO ((#0=G167307 (CDR |u|) (CDR #0#)) (|arg| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |op| (|keyp| |arg|)) + (COND + ((AND + (NULL |firstTime|) + (OR + (|needBlankForRoot| |lastOp| |op| |arg|) + (|needStar| |wasSimple| |wasQuotient| |wasNumber| |arg| |op|) + (AND + |wasNumber| + (BOOT-EQUAL |op| (QUOTE ROOT)) + (EQL (|subspan| |arg|) 1)))) + (SPADLET |d| (APP BLANK |x| |y| |d|)) (SPADLET |x| (PLUS |x| 1)))) + (SPADLET |LETTMP#1| + (|appInfixArg| |arg| |x| |y| |d| |rightPrec| (QUOTE |left|) NIL)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |x| (CADR |LETTMP#1|)) + (SPADLET |wasSimple| + (OR + (AND (ATOM |arg|) (NULL (NUMBERP |arg|))) + (|isRationalNumber| |arg|))) + (SPADLET |wasQuotient| (|isQuotient| |op|)) + (SPADLET |wasNumber| (NUMBERP |arg|)) + (SPADLET |lastOp| |op|) (SPADLET |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 + +(DEFUN |needBlankForRoot| (|lastOp| |op| |arg|) + (COND + ((AND (NEQUAL |lastOp| (QUOTE ^)) + (NEQUAL |lastOp| (QUOTE **)) + (NULL (> (|subspan| |arg|) 0))) + NIL) + ((AND (BOOT-EQUAL |op| (QUOTE **)) + (BOOT-EQUAL (|keyp| (CADR |arg|)) (QUOTE ROOT))) + (QUOTE T)) + ((AND (BOOT-EQUAL |op| (QUOTE ^)) + (BOOT-EQUAL (|keyp| (CADR |arg|)) (QUOTE ROOT))) + (QUOTE T)) + ((AND (BOOT-EQUAL |op| (QUOTE ROOT)) (CDDR |arg|)) + (QUOTE T)) + ((QUOTE T) + NIL))) + +;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 + +(DEFUN |stepApp| (#0=G167334 |x| |y| |d|) + (PROG (|a| |init| |one| |optFinal| |w|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |init| (CADDR #0#)) + (SPADLET |one| (CADDDR #0#)) + (SPADLET |optFinal| (CDDDDR #0#)) + (SPADLET |d| (|appChar| (MAKESTRING "for ") |x| |y| |d|)) + (SPADLET |d| (APP |a| (SPADLET |w| (PLUS |x| 4)) |y| |d|)) + (SPADLET |d| + (|appChar| " in " (SPADLET |w| (PLUS |w| (WIDTH |a|))) |y| |d|)) + (SPADLET |d| (APP |init| (SPADLET |w| (PLUS |w| 4)) |y| |d|)) + (SPADLET |d| (APP ".." (SPADLET |w| (PLUS |w| (WIDTH |init|))) |y| |d|)) + (COND + (|optFinal| (SPADLET |d| (APP (CAR |optFinal|) (PLUS |w| 2) |y| |d|)))) + |d|)))) + +;stepSub [.,a,init,one,:optFinal] == +; m:= MAX(subspan a,subspan init) +; optFinal => MAX(m,subspan first optFinal) +; m + +(DEFUN |stepSub| (#0=G167365) + (PROG (|a| |init| |one| |optFinal| |m|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |init| (CADDR #0#)) + (SPADLET |one| (CADDDR #0#)) + (SPADLET |optFinal| (CDDDDR #0#)) + (SPADLET |m| (MAX (|subspan| |a|) (|subspan| |init|))) + (COND + (|optFinal| (MAX |m| (|subspan| (CAR |optFinal|)))) + ((QUOTE T) |m|)))))) + +;stepSuper [.,a,init,one,:optFinal] == +; m:= MAX(superspan a,superspan init) +; optFinal => MAX(m,superspan first optFinal) +; m + +(DEFUN |stepSuper| (#0=G167387) + (PROG (|a| |init| |one| |optFinal| |m|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |init| (CADDR #0#)) + (SPADLET |one| (CADDDR #0#)) + (SPADLET |optFinal| (CDDDDR #0#)) + (SPADLET |m| (MAX (|superspan| |a|) (|superspan| |init|))) + (COND + (|optFinal| (MAX |m| (|superspan| (CAR |optFinal|)))) + ((QUOTE T) |m|)))))) + +;stepWidth [.,a,init,one,:optFinal] == +; 10+WIDTH a+WIDTH init+(optFinal => WIDTH first optFinal; 0) + +(DEFUN |stepWidth| (#0=G167409) + (PROG (|a| |init| |one| |optFinal|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |init| (CADDR #0#)) + (SPADLET |one| (CADDDR #0#)) + (SPADLET |optFinal| (CDDDDR #0#)) + (PLUS + (PLUS (PLUS 10 (WIDTH |a|)) (WIDTH |init|)) + (COND + (|optFinal| (WIDTH (CAR |optFinal|))) + ((QUOTE T) 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) + +(DEFUN |inApp| (#0=G167430 |x| |y| |d|) + (PROG (|a| |s|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |s| (CADDR #0#)) + (SPADLET |d| (|appChar| "for " |x| |y| |d|)) + (SPADLET |d| (APP |a| (PLUS |x| 4) |y| |d|)) + (SPADLET |d| (|appChar| " in " (PLUS (PLUS |x| (WIDTH |a|)) 4) |y| |d|)) + (APP |s| (PLUS (PLUS |x| (WIDTH |a|)) 8) |y| |d|))))) + +;inSub [.,a,s] == MAX(subspan a,subspan s) + +(DEFUN |inSub| (#0=G167447) + (PROG (|a| |s|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |s| (CADDR #0#)) + (MAX (|subspan| |a|) (|subspan| |s|)))))) + +;inSuper [.,a,s] == MAX(superspan a,superspan s) + +(DEFUN |inSuper| (#0=G167461) + (PROG (|a| |s|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |s| (CADDR #0#)) + (MAX (|superspan| |a|) (|superspan| |s|)))))) + +;inWidth [.,a,s] == 8+WIDTH a+WIDTH s + +(DEFUN |inWidth| (#0=G167475) + (PROG (|a| |s|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |s| (CADDR #0#)) + (PLUS (PLUS 8 (WIDTH |a|)) (WIDTH |s|)))))) + +;centerApp([.,u],x,y,d) == +; d := APP(u,x,y,d) + +(DEFUN |centerApp| (#0=G167489 |x| |y| |d|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (CADR #0#)) + (SPADLET |d| (APP |u| |x| |y| |d|)))))) + +;concatApp([.,:l],x,y,d) == concatApp1(l,x,y,d,0) + +(DEFUN |concatApp| (#0=G167501 |x| |y| |d|) + (PROG (|l|) + (RETURN + (PROGN + (SPADLET |l| (CDR #0#)) + (|concatApp1| |l| |x| |y| |d| 0))))) + +;concatbApp([.,:l],x,y,d) == concatApp1(l,x,y,d,1) + +(DEFUN |concatbApp| (#0=G167512 |x| |y| |d|) + (PROG (|l|) + (RETURN + (PROGN + (SPADLET |l| (CDR #0#)) + (|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 + +(DEFUN |concatApp1| (|l| |x| |y| |d| |n|) + (SEQ + (PROGN + (DO ((#0=G167530 |l| (CDR #0#)) (|u| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |d| (APP |u| |x| |y| |d|)) + (SPADLET |x| (PLUS (PLUS |x| (WIDTH |u|)) |n|)))))) + |d|))) + +;concatSub [.,:l] == "MAX"/[subspan x for x in l] + +(DEFUN |concatSub| (#0=G167541) + (PROG (|l|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| (CDR #0#)) + (PROG (#1=G167548) + (SPADLET #1# -999999) + (RETURN + (DO ((#2=G167553 |l| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (MAX #1# (|subspan| |x|))))))))))))) + +;concatSuper [.,:l] == "MAX"/[superspan x for x in l] + +(DEFUN |concatSuper| (#0=G167564) + (PROG (|l|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| (CDR #0#)) + (PROG (#1=G167571) + (SPADLET #1# -999999) + (RETURN + (DO ((#2=G167576 |l| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (MAX #1# (|superspan| |x|))))))))))))) + +;concatWidth [.,:l] == +/[WIDTH x for x in l] + +(DEFUN |concatWidth| (#0=G167587) + (PROG (|l|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| (CDR #0#)) + (PROG (#1=G167594) + (SPADLET #1# 0) + (RETURN + (DO ((#2=G167599 |l| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (PLUS #1# (WIDTH |x|))))))))))))) + +;concatbWidth [.,:l] == +/[1+WIDTH x for x in l]-1 + +(DEFUN |concatbWidth| (#0=G167610) + (PROG (|l|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| (CDR #0#)) + (SPADDIFFERENCE + (PROG (#1=G167617) + (SPADLET #1# 0) + (RETURN + (DO ((#2=G167622 |l| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (PLUS #1# (PLUS 1 (WIDTH |x|))))))))) 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) + +(DEFUN |exptApp| (#0=G167637 |x| |y| |d|) + (PROG (|a| |b| |pren| |x'| |y'|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |b| (CADDR #0#)) + (SPADLET |pren| (|exptNeedsPren| |a|)) + (SPADLET |d| + (COND + (|pren| (|appparu| |a| |x| |y| |d|)) + ((QUOTE T) (APP |a| |x| |y| |d|)))) + (SPADLET |x'| + (PLUS (PLUS |x| (WIDTH |a|)) (COND (|pren| 2) ((QUOTE T) 0)))) + (SPADLET |y'| + (PLUS + (PLUS (PLUS (PLUS 1 |y|) (|superspan| |a|)) (|subspan| |b|)) + (COND ((EQL 0 (|superspan| |a|)) 0) ((QUOTE T) (SPADDIFFERENCE 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 + +(DEFUN |exptNeedsPren| (|a|) + (PROG (|key|) + (RETURN + (COND + ((AND (ATOM |a|) (NULL (AND (INTEGERP |a|) (MINUSP |a|)))) NIL) + ((QUOTE T) + (SPADLET |key| (|keyp| |a|)) + (COND + ((BOOT-EQUAL |key| (QUOTE OVER)) (QUOTE T)) + ((OR (BOOT-EQUAL |key| (QUOTE SUB)) + (AND + (NULL (GETL |key| (QUOTE |Nud|))) + (NULL (GETL |key| (QUOTE |Led|))))) + NIL) + ((QUOTE T) (QUOTE T)))))))) + +;exptSub u == subspan CADR u + +(DEFUN |exptSub| (|u|) (|subspan| (CADR |u|))) + +;exptSuper [.,a,b] == superspan a+height b+(superspan a=0 => 0;-1) + +(DEFUN |exptSuper| (#0=G167664) + (PROG (|a| |b|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |b| (CADDR #0#)) + (PLUS + (PLUS (|superspan| |a|) (|height| |b|)) + (COND ((EQL (|superspan| |a|) 0) 0) ((QUOTE T) (SPADDIFFERENCE 1)))))))) + +;exptWidth [.,a,b] == WIDTH a+WIDTH b+(exptNeedsPren a => 2;0) + +(DEFUN |exptWidth| (#0=G167679) + (PROG (|a| |b|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (SPADLET |b| (CADDR #0#)) + (PLUS + (PLUS (WIDTH |a|) (WIDTH |b|)) + (COND ((|exptNeedsPren| |a|) 2) ((QUOTE T) 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)) + +(DEFUN |needStar| (|wasSimple| |wasQuotient| |wasNumber| |cur| |op|) + (COND + ((OR |wasQuotient| (|isQuotient| |op|)) (QUOTE T)) + (|wasSimple| + (OR (ATOM |cur|) + (BOOT-EQUAL (|keyp| |cur|) (QUOTE SUB)) + (|isRationalNumber| |cur|) + (BOOT-EQUAL |op| (QUOTE **)) + (BOOT-EQUAL |op| (QUOTE ^)) + (AND (ATOM |op|) (NULL (NUMBERP |op|)) (NULL (GETL |op| (QUOTE APP)))))) + (|wasNumber| + (OR + (NUMBERP |cur|) + (|isRationalNumber| |cur|) + (AND + (OR (BOOT-EQUAL |op| (QUOTE **)) (BOOT-EQUAL |op| (QUOTE ^))) + (NUMBERP (CADR |cur|))))))) + +;isQuotient op == +; op="/" or op="OVER" + +(DEFUN |isQuotient| (|op|) + (OR + (BOOT-EQUAL |op| (QUOTE /)) + (BOOT-EQUAL |op| (QUOTE 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 + +(DEFUN |timesWidth| (|u|) + (PROG (|rightPrec| |op| |w| |wasSimple| |wasQuotient| |wasNumber| |firstTime|) + (RETURN + (SEQ + (PROGN + (SPADLET |rightPrec| + (|getOpBindingPower| (QUOTE *) (QUOTE |Led|) (QUOTE |right|))) + (SPADLET |firstTime| (QUOTE T)) + (SPADLET |w| 0) + (DO ((#0=G167713 (CDR |u|) (CDR #0#)) (|arg| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |op| (|keyp| |arg|)) + (COND + ((AND (NULL |firstTime|) + (|needStar| |wasSimple| |wasQuotient| |wasNumber| |arg| |op|)) + (SPADLET |w| (PLUS |w| 1)))) + (COND + ((|infixArgNeedsParens| |arg| |rightPrec| (QUOTE |left|)) + (SPADLET |w| (PLUS |w| 2)))) + (SPADLET |w| (PLUS |w| (WIDTH |arg|))) + (SPADLET |wasSimple| (AND (ATOM |arg|) (NULL (NUMBERP |arg|)))) + (SPADLET |wasQuotient| (|isQuotient| |op|)) + (SPADLET |wasNumber| (NUMBERP |arg|)) + (SPADLET |firstTime| NIL))))) + |w|))))) + +;plusApp([.,frst,:rst],x,y,d) == +; appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d)) + +(DEFUN |plusApp| (#0=G167733 |x| |y| |d|) + (PROG (|frst| |rst|) + (RETURN + (PROGN + (SPADLET |frst| (CADR #0#)) + (SPADLET |rst| (CDDR #0#)) + (|appSum| |rst| + (PLUS |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 + +(DEFUN |appSum| (|u| |x| |y| |d|) + (PROG (|infixOp| |opString| |arg| |rightPrec| |LETTMP#1|) + (RETURN + (SEQ + (PROGN + (DO ((#0=G167771 |u| (CDR #0#)) (|arg| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |infixOp| + (COND + ((|syminusp| |arg|) (QUOTE -)) + ((QUOTE T) (QUOTE +)))) + (SPADLET |opString| + (OR (GETL |infixOp| (QUOTE INFIXOP)) (MAKESTRING ","))) + (SPADLET |d| (APP |opString| |x| |y| |d|)) + (SPADLET |x| (PLUS |x| (WIDTH |opString|))) + (SPADLET |arg| (|absym| |arg|)) + (SPADLET |rightPrec| + (|getOpBindingPower| |infixOp| (QUOTE |Led|) (QUOTE |right|))) + (COND + ((BOOT-EQUAL |infixOp| (QUOTE -)) + (SPADLET |rightPrec| (PLUS |rightPrec| 1)))) + (SPADLET |LETTMP#1| + (|appInfixArg| |arg| |x| |y| |d| |rightPrec| (QUOTE |left|) NIL)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |x| (CADR |LETTMP#1|)) + |LETTMP#1|)))) + |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 + +(DEFUN |appInfix| (|e| |x| |y| |d|) + (PROG (|op| |leftPrec| |rightPrec| |opString| |opWidth| |frst| + |rst| |LETTMP#1|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (|keyp| |e|)) + (SPADLET |leftPrec| + (|getOpBindingPower| |op| (QUOTE |Led|) (QUOTE |left|))) + (COND + ((EQL |leftPrec| 1000) (RETURN NIL)) + ((QUOTE T) + (SPADLET |rightPrec| + (|getOpBindingPower| |op| (QUOTE |Led|) (QUOTE |right|))) + (COND + ((QSLESSP (|#| |e|) 2) + (|throwKeyedMsg| (QUOTE S2IX0008) + (CONS (QUOTE |appInfix|) + (CONS "fewer than 2 arguments to an infix function" NIL)))) + ((QUOTE T) + (SPADLET |opString| (OR (GETL |op| (QUOTE INFIXOP)) (MAKESTRING ","))) + (SPADLET |opWidth| (WIDTH |opString|)) + (SPADLET |frst| (CADR |e|)) + (SPADLET |rst| (CDDR |e|)) + (COND + ((NULL |rst|) + (COND + ((GETL |op| (QUOTE |isSuffix|)) + (SPADLET |LETTMP#1| + (|appInfixArg| |frst| |x| |y| |d| |leftPrec| + (QUOTE |right|) |opString|)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |x| (CADR |LETTMP#1|)) + (SPADLET |d| (|appChar| |opString| |x| |y| |d|))) + ((QUOTE T) + (THROW (QUOTE |outputFailure|) (QUOTE |outputFailure|))))) + ((QUOTE T) + (SPADLET |LETTMP#1| + (|appInfixArg| |frst| |x| |y| |d| |leftPrec| + (QUOTE |right|) |opString|)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |x| (CADR |LETTMP#1|)) + (DO ((#0=G167827 |rst| (CDR #0#)) (|arg| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |d| (|appChar| |opString| |x| |y| |d|)) + (SPADLET |x| (PLUS |x| |opWidth|)) + (SPADLET |LETTMP#1| + (|appInfixArg| |arg| |x| |y| |d| |rightPrec| + (QUOTE |left|) |opString|)) + (SPADLET |d| (CAR |LETTMP#1|)) + (SPADLET |x| (CADR |LETTMP#1|)) + |LETTMP#1|)))) + |d|))))))))))) + +;appconc(d,x,y,w) == NCONC(d,[[[x,:y],:w]]) + +(DEFUN |appconc| (|d| |x| |y| |w|) + (NCONC |d| (CONS (CONS (CONS |x| |y|) |w|) NIL))) + +;infixArgNeedsParens(arg, prec, leftOrRight) == +; prec > getBindingPowerOf(leftOrRight, arg) + 1 + +(DEFUN |infixArgNeedsParens| (|arg| |prec| |leftOrRight|) + (> |prec| (PLUS (|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)] + +(DEFUN |appInfixArg| (|u| |x| |y| |d| |prec| |leftOrRight| |string|) + (PROG (|insertPrensIfTrue|) + (RETURN + (PROGN + (SPADLET |insertPrensIfTrue| + (|infixArgNeedsParens| |u| |prec| |leftOrRight|)) + (SPADLET |d| + (COND + (|insertPrensIfTrue| (|appparu| |u| |x| |y| |d|)) + ((QUOTE T) (APP |u| |x| |y| |d|)))) + (SPADLET |x| (PLUS |x| (WIDTH |u|))) + (COND (|string| (SPADLET |d| (|appconc| |d| |x| |y| |string|)))) + (CONS |d| + (CONS (COND (|insertPrensIfTrue| (PLUS |x| 2)) ((QUOTE T) |x|)) NIL)))))) + +;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 + +(DEFUN |getBindingPowerOf| (|key| |x|) + (PROG (|argl| |a| |op| |n| |m|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE REDUCE))) + (COND + ((BOOT-EQUAL |key| (QUOTE |left|)) 130) + ((BOOT-EQUAL |key| (QUOTE |right|)) 0))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE REPEAT))) + (COND + ((BOOT-EQUAL |key| (QUOTE |left|)) 130) + ((BOOT-EQUAL |key| (QUOTE |right|)) 0))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE COND))) + (COND + ((BOOT-EQUAL |key| (QUOTE |left|)) 130) + ((BOOT-EQUAL |key| (QUOTE |right|)) 0))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + (QUOTE T))) + (COND + ((AND (PAIRP |op|) (PROGN (SPADLET |a| (QCAR |op|)) (QUOTE T))) + (SPADLET |op| |a|))) + (COND + ((BOOT-EQUAL |op| (QUOTE SLASH)) + (SPADDIFFERENCE (|getBindingPowerOf| |key| (CONS (QUOTE /) |argl|)) 1)) + ((BOOT-EQUAL |op| (QUOTE OVER)) + (|getBindingPowerOf| |key| (CONS (QUOTE /) |argl|))) + ((EQL (SPADLET |n| (|#| |argl|)) 1) + (COND + ((AND + (BOOT-EQUAL |key| (QUOTE |left|)) + (SPADLET |m| + (|getOpBindingPower| |op| (QUOTE |Nud|) (QUOTE |left|)))) + |m|) + ((AND + (BOOT-EQUAL |key| (QUOTE |right|)) + (SPADLET |m| + (|getOpBindingPower| |op| (QUOTE |Nud|) (QUOTE |right|)))) + |m|) + ((QUOTE T) 1000))) + ((> |n| 1) + (COND + ((AND + (BOOT-EQUAL |key| (QUOTE |left|)) + (SPADLET |m| + (|getOpBindingPower| |op| (QUOTE |Led|) (QUOTE |left|)))) + |m|) + ((AND + (BOOT-EQUAL |key| (QUOTE |right|)) + (SPADLET |m| + (|getOpBindingPower| |op| (QUOTE |Led|) (QUOTE |right|)))) + |m|) + ((BOOT-EQUAL |op| (QUOTE ELT)) 1002) + ((QUOTE T) 1000))) + ((QUOTE T) 1000))) + ((QUOTE T) 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 + +(DEFUN |getOpBindingPower| (|op| |LedOrNud| |leftOrRight|) + (PROG (|exception| |bp|) + (RETURN + (PROGN + (COND ((|member| |op| (QUOTE (SLASH OVER))) (SPADLET |op| (QUOTE /)))) + (SPADLET |exception| + (COND + ((BOOT-EQUAL |leftOrRight| (QUOTE |left|)) 0) + ((QUOTE T) 105))) + (SPADLET |bp| + (COND + ((BOOT-EQUAL |leftOrRight| (QUOTE |left|)) + (|leftBindingPowerOf| |op| |LedOrNud|)) + ((QUOTE T) + (|rightBindingPowerOf| |op| |LedOrNud|)))) + (COND + ((NEQUAL |bp| |exception|) |bp|) + ((QUOTE T) 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) + +(DEFUN |bracketApp| (|u| |x| |y| |d|) + (PROG (|ISTMP#1|) + (RETURN + (PROGN + (OR + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) (QUOTE T))))) + (THROW (QUOTE |outputFailure|) (QUOTE |outputFailure|))) + (SPADLET |d| (|appChar| (|specialChar| (QUOTE |lbrk|)) |x| |y| |d|)) + (SPADLET |d| (APP |u| (PLUS |x| 1) |y| |d|)) + (|appChar| + (|specialChar| (QUOTE |rbrk|)) + (PLUS (PLUS |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) + +(DEFUN |braceApp| (|u| |x| |y| |d|) + (PROG (|ISTMP#1|) + (RETURN + (PROGN + (OR + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) (QUOTE T))))) + (THROW (QUOTE |outputFailure|) (QUOTE |outputFailure|))) + (SPADLET |d| (|appChar| (|specialChar| (QUOTE |lbrc|)) |x| |y| |d|)) + (SPADLET |d| (APP |u| (PLUS |x| 1) |y| |d|)) + (|appChar| + (|specialChar| (QUOTE |rbrc|)) + (PLUS (PLUS |x| 1) (WIDTH |u|)) + |y| + |d|))))) + +;--% Aggregates +;aggWidth u == +; rest u is [a,:l] => WIDTH a + +/[1+WIDTH x for x in l] +; 0 + +(DEFUN |aggWidth| (|u|) + (PROG (|ISTMP#1| |a| |l|) + (RETURN + (SEQ + (COND + ((PROGN + (SPADLET |ISTMP#1| (CDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PLUS + (WIDTH |a|) + (PROG (#0=G167935) + (SPADLET #0# 0) + (RETURN + (DO ((#1=G167940 |l| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (PLUS #0# (PLUS 1 (WIDTH |x|))))))))))) + ((QUOTE T) 0)))))) + +;aggSub u == subspan rest u + +(DEFUN |aggSub| (|u|) (|subspan| (CDR |u|))) + +;aggSuper u == superspan rest u + +(DEFUN |aggSuper| (|u|) (|superspan| (CDR |u|))) + +;aggApp(u,x,y,d) == aggregateApp(rest u,x,y,d,",") + +(DEFUN |aggApp| (|u| |x| |y| |d|) + (|aggregateApp| (CDR |u|) |x| |y| |d| (QUOTE |,|))) + +;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 + +(DEFUN |aggregateApp| (|u| |x| |y| |d| |s|) + (PROG (|a| |l|) + (RETURN + (SEQ + (PROGN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |a| (QCAR |u|)) + (SPADLET |l| (QCDR |u|)) + (QUOTE T))) + (SPADLET |d| (APP |a| |x| |y| |d|)) + (SPADLET |x| (PLUS |x| (WIDTH |a|))) + (DO ((#0=G167974 |l| (CDR #0#)) (|b| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |b| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |d| (APP |s| |x| |y| |d|)) + (SPADLET |d| (APP |b| (PLUS |x| 1) |y| |d|)) + (SPADLET |x| (PLUS (PLUS |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 + +(DEFUN |outformWidth| (|u|) + (COND + ((STRINGP |u|) + (COND + ((BOOT-EQUAL |u| |$EmptyString|) 0) + ((AND + (BOOT-EQUAL (ELT |u| 0) (QUOTE %)) + (OR + (BOOT-EQUAL (ELT |u| 1) (|char| (QUOTE |b|))) + (BOOT-EQUAL (ELT |u| 1) (|char| (QUOTE |d|))))) + 1) + ((QUOTE T) (|#| |u|)))) + ((ATOM |u|) (|#| (|atom2String| |u|))) + ((QUOTE T) (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 => +; u = 0 => 1 +; if (u < 1) then +; negative := 1 +; else +; negative := 0 +; DIGITS_-BY_-RADIX(u, 10) + negative +; atom u => # atom2String u +; putWidth u is [[.,:n],:.] => n +; THROW('outputFailure,'outputFailure) + +(DEFUN WIDTH (|u|) + (PROG (|negative| |ISTMP#1| |ISTMP#2| |n|) + (RETURN + (COND + ((STRINGP |u|) + (COND + ((BOOT-EQUAL |u| |$EmptyString|) 0) + ((AND + (BOOT-EQUAL (ELT |u| 0) (QUOTE %)) + (OR + (BOOT-EQUAL (ELT |u| 1) (|char| (QUOTE |b|))) + (BOOT-EQUAL (ELT |u| 1) (|char| (QUOTE |d|))))) + 1) + ((QUOTE T) (|#| |u|)))) + ((INTEGERP |u|) + (COND + ((EQL |u| 0) 1) + ((QUOTE T) + (COND + ((> 1 |u|) (SPADLET |negative| 1)) + ((QUOTE T) (SPADLET |negative| 0))) + (PLUS (DIGITS-BY-RADIX |u| 10) |negative|)))) + ((ATOM |u|) (|#| (|atom2String| |u|))) + ((PROGN + (SPADLET |ISTMP#1| (|putWidth| |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET |n| (QCDR |ISTMP#2|)) (QUOTE T)))))) + |n|) + ((QUOTE T) (THROW (QUOTE |outputFailure|) (QUOTE |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:= +; 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 + +(DEFUN |putWidth| (|u|) + (PROG (|ISTMP#1| |n| |op| |leftPrec| |rightPrec| |firstEl| |l| |interSpace| + |firstArg| |restArg| |widthFirstArg| |argsWidth| |oldFirst| |fn| + |ll| |newFirst|) + (RETURN + (SEQ + (COND + ((OR (ATOM |u|) + (AND + (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |n| (QCDR |ISTMP#1|)) (QUOTE T)))) + (NUMBERP |n|))) + |u|) + ((QUOTE T) + (SPADLET |op| (|keyp| |u|)) + (SPADLET |leftPrec| (|getBindingPowerOf| (QUOTE |left|) |u|)) + (SPADLET |rightPrec| (|getBindingPowerOf| (QUOTE |right|) |u|)) + (SPADLET |firstEl| (CAR |u|)) + (SPADLET |l| (CDR |u|)) + (SPADLET |interSpace| + (COND + ((GETL |firstEl| (QUOTE INFIXOP)) 0) + ((QUOTE T) 1))) + (SPADLET |argsWidth| + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |firstArg| (QCAR |l|)) + (SPADLET |restArg| (QCDR |l|)) + (QUOTE T))) + (RPLACA (CDR |u|) (|putWidth| |firstArg|)) + (DO ((|y| |restArg| (CDR |y|))) + ((ATOM |y|) NIL) + (SEQ (EXIT (RPLACA |y| (|putWidth| (CAR |y|)))))) + (SPADLET |widthFirstArg| + (COND + ((AND + (EQL 0 |interSpace|) + (|infixArgNeedsParens| |firstArg| |leftPrec| (QUOTE |right|))) + (PLUS 2 (WIDTH |firstArg|))) + ((QUOTE T) (WIDTH |firstArg|)))) + (PLUS |widthFirstArg| + (PROG (#0=G168041) + (SPADLET #0# 0) + (RETURN + (DO ((#1=G168046 |restArg| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (PLUS #0# + (PLUS |interSpace| + (COND + ((AND + (EQL 0 |interSpace|) + (|infixArgNeedsParens| |x| |rightPrec| (QUOTE |left|))) + (PLUS 2 (WIDTH |x|))) + ((QUOTE T) (WIDTH |x|))))))))))))) + ((QUOTE T) 0))) + (SPADLET |newFirst| + (COND + ((ATOM (SPADLET |oldFirst| (CAR |u|))) + (COND + ((SPADLET |fn| (GETL |oldFirst| (QUOTE WIDTH))) + (CONS |oldFirst| (FUNCALL |fn| (CONS |oldFirst| |l|)))) + ((QUOTE T) + (COND (|l| (SPADLET |ll| (CDR |l|))) ((QUOTE T) (SPADLET |ll| NIL))) + (CONS |oldFirst| (PLUS (|opWidth| |oldFirst| |ll|) |argsWidth|))))) + ((QUOTE T) + (CONS + (|putWidth| |oldFirst|) + (PLUS (PLUS 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 + +(DEFUN |opWidth| (|op| |has2Arguments|) + (PROG (|a|) + (RETURN + (COND + ((BOOT-EQUAL |op| (QUOTE EQUATNUM)) 4) + ((NUMBERP |op|) (PLUS 2 (SIZE (STRINGIMAGE |op|)))) + ((NULL |has2Arguments|) + (COND + ((SPADLET |a| (GETL |op| (QUOTE PREFIXOP))) (SIZE |a|)) + ((QUOTE T) (PLUS 2 (SIZE (PNAME |op|)))))) + ((SPADLET |a| (GETL |op| (QUOTE INFIXOP))) (SIZE |a|)) + ((QUOTE T) (PLUS 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 + +(DEFUN |matrixBorder| (|x| |y1| |y2| |d| |leftOrRight|) + (PROG (|c|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |y1| |y2|) + (SPADLET |c| + (COND + ((BOOT-EQUAL |leftOrRight| (QUOTE |left|)) + (|specialChar| (QUOTE |lbrk|))) + ((QUOTE T) + (|specialChar| (QUOTE |rbrk|))))) + (APP |c| |x| |y1| |d|)) + ((QUOTE T) + (DO ((|y| |y1| (+ |y| 1))) + ((> |y| |y2|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |c| + (COND + ((BOOT-EQUAL |y| |y1|) + (COND + ((BOOT-EQUAL |leftOrRight| (QUOTE |left|)) + (|specialChar| (QUOTE |llc|))) + ((QUOTE T) + (|specialChar| (QUOTE |lrc|))))) + ((BOOT-EQUAL |y| |y2|) + (COND + ((BOOT-EQUAL |leftOrRight| (QUOTE |left|)) + (|specialChar| (QUOTE |ulc|))) + ((QUOTE T) + (|specialChar| (QUOTE |urc|))))) + ((QUOTE T) (|specialChar| (QUOTE |vbar|))))) + (SPADLET |d| (APP |c| |x| |y| |d|)))))) + |d|)))))) + +;isRationalNumber x == nil + +(DEFUN |isRationalNumber| (|x|) NIL) + +;widthSC u == 10000 + +(DEFUN |widthSC| (|u|) 10000) + +;--% The over-large matrix package +;maprinSpecial(x,$MARGIN,$LINELENGTH) == maprin0 x + +(DEFUN |maprinSpecial| (|x| $MARGIN $LINELENGTH) + (DECLARE (SPECIAL $MARGIN $LINELENGTH)) + (|maprin0| |x|)) + +;maprin x == +; if $demoFlag=true then recordOrCompareDemoResult x +; CATCH('output,maprin0 x) +; nil + +(DEFUN |maprin| (|x|) + (PROGN + (COND ((BOOT-EQUAL |$demoFlag| (QUOTE T)) (|recordOrCompareDemoResult| |x|))) + (CATCH (QUOTE |output|) (|maprin0| |x|)) NIL)) + +;maprin0 x == +; $MatrixCount:local :=0 +; $MatrixList:local :=nil +; maprinChk x +; if $MatrixList then maprinRows $MatrixList + +(DEFUN |maprin0| (|x|) + (PROG (|$MatrixCount| |$MatrixList|) + (DECLARE (SPECIAL |$MatrixCount| |$MatrixList|)) + (RETURN + (PROGN + (SPADLET |$MatrixCount| 0) + (SPADLET |$MatrixList| NIL) + (|maprinChk| |x|) + (COND (|$MatrixList| (|maprinRows| |$MatrixList|)) ((QUOTE T) NIL)))))) + +;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 + +(DEFUN |maprinChk| (|x|) + (PROG (|arg| |n| |ISTMP#2| |y| |ISTMP#1| |name| |value| |u|) + (RETURN + (COND + ((NULL |$MatrixList|) (|maPrin| |x|)) + ((AND (ATOM |x|) (SPADLET |u| (|assoc| |x| |$MatrixList|))) + (SPADLET |$MatrixList| (|delete| |u| |$MatrixList|)) + (|maPrin| (|deMatrix| (CDR |u|)))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE =)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |arg| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((SPADLET |u| (|assoc| |y| |$MatrixList|)) + (SPADLET |$MatrixList| (|delete| |u| |$MatrixList|)) + (|maPrin| + (CONS (QUOTE =) (CONS |arg| (CONS (|deMatrix| (CDR |u|)) NIL))))) + ((QUOTE T) (|maPrin| |x|)))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE EQUATNUM)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((AND (PAIRP |$MatrixList|) + (EQ (QCDR |$MatrixList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |$MatrixList|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |value| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (BOOT-EQUAL |y| |name|)) + (SPADLET |$MatrixList| NIL) + (|maPrin| + (CONS (QUOTE EQUATNUM) (CONS |n| (CONS (|deMatrix| |value|) NIL))))) + ((IDENTP |y|) + (SPADLET |u| (|assoc| |y| |$MatrixList|)) + (SPADLET |$MatrixList| (|delete| |u| |$MatrixList|)) + (|maPrin| (CONS (QUOTE EQUATNUM) (CONS |n| (CONS (CDR |u|) NIL)))) + (COND + ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|)) + ((QUOTE T) NIL))) + ((QUOTE T) (|maPrin| |x|)))) + ((QUOTE T) (|maPrin| |x|)))))) + +;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] + +(DEFUN |maprinRows| (|matrixList|) + (PROG (|y| |firstName| |name| |m| |andWhere| |line|) + (RETURN + (SEQ + (PROGN + (COND ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) + (DO () + ((NULL |matrixList|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |y| (NREVERSE |matrixList|)) + (SPADLET |matrixList| NIL) + (SPADLET |firstName| (CAR (CAR |y|))) + (DO ((#0=G168227 |y| (CDR #0#)) + (#1=G168195 NIL) + (|n| 0 (QSADD1 |n|))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR #1#)) + (SPADLET |m| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (COND ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) + (SPADLET |andWhere| + (COND + ((BOOT-EQUAL |name| |firstName|) (MAKESTRING "where ")) + ((QUOTE T) (MAKESTRING "and ")))) + (SPADLET |line| (STRCONC |andWhere| (PNAME |name|))) + (|maprinChk| + (CONS (QUOTE =) (CONS |line| (CONS |m| NIL))))))))))))))))) + +; -- 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]]] + +(DEFUN |deMatrix| (|m|) + (PROG NIL + (RETURN + (SEQ + (CONS (QUOTE BRACKET) + (CONS + (CONS (QUOTE AGGLST) + (PROG (#0=G168248) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=G168253 (CDDR |m|) (CDR #1#)) (|row| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |row| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS (QUOTE BRACKET) + (CONS (CONS (QUOTE AGGLST) (CDR |row|)) NIL)) + #0#)))))))) + NIL)))))) + +;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 + +(DEFUN |LargeMatrixp| (|u| |width| |dist|) + (PROG (|op| |n| |ans|) + (RETURN + (SEQ + (COND + ((ATOM |u|) NIL) + ((<= (CDAR |u|) |width|) NIL) + ((QUOTE T) + (SPADLET |op| (CAAR |u|)) + (COND + ((BOOT-EQUAL |op| (QUOTE MATRIX)) (|largeMatrixAlist| |u|)) + ((MEMQ |op| + (QUOTE (LET RARROW SEGMENT - CONCAT CONCATB PAREN BRACKET BRACE))) + (SPADLET |dist| (SPADDIFFERENCE |dist| 3)) + (SPADLET |width| (SPADDIFFERENCE |width| 3)) + (SPADLET |ans| + (DO ((#0=G168272 (CDR |u|) (CDR #0#)) (|v| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |v| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((SPADLET |ans| (|LargeMatrixp| |v| |width| |dist|)) + (RETURN (|largeMatrixAlist| |ans|))) + ((QUOTE T) + (SPADLET |dist| (SPADDIFFERENCE |dist| (WIDTH |v|))) + (COND ((MINUSP |dist|) (RETURN NIL))))))))) + |ans|) + ((MEMQ |op| (QUOTE (+ *))) + (COND + ((SPADLET |ans| + (|LargeMatrixp| (CADR |u|) (SPADDIFFERENCE |width| 3) |dist|)) + (|largeMatrixAlist| |ans|)) + ((QUOTE T) + (SPADLET |n| (PLUS 3 (WIDTH (CADR |u|)))) + (SPADLET |dist| (SPADDIFFERENCE |dist| |n|)) + (SPADLET |ans| + (DO ((#1=G168281 (CDDR |u|) (CDR #1#)) (|v| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |v| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((SPADLET |ans| (|LargeMatrixp| |v| |width| |dist|)) + (RETURN (|largeMatrixAlist| |ans|))) + ((QUOTE T) + (SPADLET |dist| (SPADDIFFERENCE |dist| (WIDTH |v|))) + (COND ((MINUSP |dist|) (RETURN NIL))))))))) + |ans|))) + ((QUOTE T) + (SPADLET |ans| + (DO ((#2=G168290 (CDR |u|) (CDR #2#)) (|v| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |v| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((SPADLET |ans| (|LargeMatrixp| |v| |width| |dist|)) + (RETURN (|largeMatrixAlist| |ans|))) + ((QUOTE T) + (SPADLET |dist| (SPADDIFFERENCE |dist| (WIDTH |v|))) + (COND ((MINUSP |dist|) (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 + +(DEFUN |largeMatrixAlist| (|u|) + (PROG (|op| |r|) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN (SPADLET |op| (QCAR |u|)) (SPADLET |r| (QCDR |u|)) (QUOTE T))) + (COND + ((AND (PAIRP |op|) (EQ (QCAR |op|) (QUOTE MATRIX))) (|deMatrix| |u|)) + ((QUOTE T) (OR (|largeMatrixAlist| |op|) (|largeMatrixAlist| |r|))))) + ((QUOTE T) 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 + +(DEFUN |PushMatrix| (|m|) + (PROG (|name|) + (RETURN + (SEQ + (SPADLET |name| + (DO ((#0=G168328 |$MatrixList| (CDR #0#)) (|v| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |v| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |m| (CDR |v|)) (EXIT (RETURN (CAR |v|))))))))) + (COND (|name| (EXIT |name|))) + (SPADLET |name| + (INTERNL "matrix" + (STRINGIMAGE (SPADLET |$MatrixCount| (PLUS |$MatrixCount| 1))))) + (SPADLET |$MatrixList| (CONS (CONS |name| |m|) |$MatrixList|)) + (EXIT |name|))))) + +;quoteApp([.,a],x,y,d) == APP(a,x+1,y,appChar(PNAME "'",x,y,d)) + +(DEFUN |quoteApp| (#0=G168341 |x| |y| |d|) + (PROG (|a|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (APP |a| (PLUS |x| 1) |y| (|appChar| (PNAME (QUOTE |'|)) |x| |y| |d|)))))) + +;quoteSub [.,a] == subspan a + +(DEFUN |quoteSub| (#0=G168352) + (PROG (|a|) + (RETURN (PROGN (SPADLET |a| (CADR #0#)) (|subspan| |a|))))) + +;quoteSuper [.,a] == superspan a + +(DEFUN |quoteSuper| (#0=G168363) + (PROG (|a|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (|superspan| |a|))))) + +;quoteWidth [.,a] == 1 + WIDTH a + +(DEFUN |quoteWidth| (#0=G168374) + (PROG (|a|) + (RETURN + (PROGN + (SPADLET |a| (CADR #0#)) + (PLUS 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'] + +(DEFUN |SubstWhileDesizing| (|u| |m|) + (PROG (|op| |n| |l| |l'|) + (RETURN + (COND + ((ATOM |u|) |u|) + ((QUOTE T) + (SPADLET |op| (CAAR |u|)) + (SPADLET |n| (CDAR |u|)) + (SPADLET |l| (CDR |u|)) + (COND + ((BOOT-EQUAL |op| (QUOTE MATRIX)) + (SPADLET |l'| (|SubstWhileDesizingList| (CDR |l|) |m|)) + (SPADLET |u| (CONS |op| (CONS NIL |l'|))) + (|PushMatrix| |u|)) + ((QUOTE T) + (SPADLET |l'| (|SubstWhileDesizingList| |l| |m|)) + (COND + ((ATOM |op|) (CONS |op| |l'|)) + ((QUOTE T) (CONS (|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 + +(DEFUN |SubstWhileDesizingList| (|u| |m|) + (PROG (|a| |b| |res| |tail|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |u|) (PROGN (SPADLET |a| (QCAR |u|)) (SPADLET |b| (QCDR |u|)) (QUOTE T))) + (SPADLET |res| (COND ((ATOM |a|) (CONS |a| NIL)) ((QUOTE T) (CONS (|SubstWhileDesizing| |a| |m|) NIL)))) + (SPADLET |tail| |res|) + (DO ((#0=G168412 |b| (CDR #0#)) (|i| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |i| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((ATOM |i|) (RPLACD |tail| (CONS |i| NIL))) + ((QUOTE T) + (RPLACD |tail| + (CONS (|SubstWhileDesizing| |i| |m|) NIL)))) + (SPADLET |tail| (CDR |tail|)))))) + |res|) + ((QUOTE T) |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) + +(DEFUN |sigmaSub| (|u|) + (MAX (PLUS 1 (|height| (CADR |u|))) (|subspan| (CADDR |u|)))) + +;sigmaSup u == +; --The height function for sigmas with lower limit only +; MAX(1, superspan CADDR u) + +(DEFUN |sigmaSup| (|u|) (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) + +(DEFUN |sigmaApp| (|u| |x| |y| |d|) + (PROG (|ISTMP#1| |bot| |ISTMP#2| |arg|) + (RETURN + (PROGN + (OR + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |bot| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |arg| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (THROW (QUOTE |outputFailure|) (QUOTE |outputFailure|))) + (|bigopAppAux| |bot| NIL |arg| |x| |y| |d| (QUOTE |sigma|)))))) + +;sigma2App(u,x,y,d) == +; [.,bot,top,arg]:=u +; bigopAppAux(bot,top,arg,x,y,d,'sigma) + +(DEFUN |sigma2App| (|u| |x| |y| |d|) + (PROG (|bot| |top| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR |u|)) + (SPADLET |top| (CADDR |u|)) + (SPADLET |arg| (CADDDR |u|)) + (|bigopAppAux| |bot| |top| |arg| |x| |y| |d| (QUOTE |sigma|)))))) + +;bigopWidth(bot,top,arg,kind) == +; kindWidth := (kind = 'pi => 5; 3) +; MAX(kindWidth,WIDTH bot,(top => WIDTH top; 0)) + 2 + WIDTH arg + +(DEFUN |bigopWidth| (|bot| |top| |arg| |kind|) + (PROG (|kindWidth|) + (RETURN + (PROGN + (SPADLET |kindWidth| + (COND ((BOOT-EQUAL |kind| '|pi|) 5) ('T 3))) + (PLUS (PLUS (MAX |kindWidth| (WIDTH |bot|) + (COND (|top| (WIDTH |top|)) ('T 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) + +(DEFUN |bigopAppAux| (|bot| |top| |arg| |x| |y| |d| |kind|) + (PROG (|botWidth| |topWidth| |opWidth| |maxWidth| |xCenter| |delta| + |opCode|) + (RETURN + (PROGN + (SPADLET |botWidth| (COND (|bot| (WIDTH |bot|)) ('T 0))) + (SPADLET |topWidth| (WIDTH |top|)) + (SPADLET |opWidth| (COND ((BOOT-EQUAL |kind| '|pi|) 5) ('T 3))) + (SPADLET |maxWidth| (MAX |opWidth| |botWidth| |topWidth|)) + (SPADLET |xCenter| + (PLUS (QUOTIENT (SPADDIFFERENCE |maxWidth| 1) 2) |x|)) + (SPADLET |d| + (APP |arg| (PLUS (PLUS |x| 2) |maxWidth|) |y| |d|)) + (SPADLET |d| + (COND + ((AND (ATOM |bot|) + (EQL (SIZE (|atom2String| |bot|)) 1)) + (APP |bot| |xCenter| (SPADDIFFERENCE |y| 2) |d|)) + ('T + (APP |bot| + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE |maxWidth| + |botWidth|) + 2)) + (SPADDIFFERENCE (SPADDIFFERENCE |y| 2) + (|superspan| |bot|)) + |d|)))) + (COND + (|top| (SPADLET |d| + (COND + ((AND (ATOM |top|) + (EQL (SIZE (|atom2String| |top|)) 1)) + (APP |top| |xCenter| (PLUS |y| 2) |d|)) + ('T + (APP |top| + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE |maxWidth| + |topWidth|) + 2)) + (PLUS (PLUS |y| 2) (|subspan| |top|)) + |d|)))))) + (SPADLET |delta| (COND ((BOOT-EQUAL |kind| '|pi|) 2) ('T 1))) + (SPADLET |opCode| + (COND + ((BOOT-EQUAL |kind| '|sigma|) + (CONS (CONS '(0 . 0) (MAKESTRING ">")) + (CONS (CONS '(0 . 1) (|specialChar| '|hbar|)) + (CONS (CONS '(0 . -1) + (|specialChar| '|hbar|)) + (CONS + (CONS '(1 . 1) + (|specialChar| '|hbar|)) + (CONS + (CONS '(1 . -1) + (|specialChar| '|hbar|)) + (CONS + (CONS '(2 . 1) + (|specialChar| '|urc|)) + (CONS + (CONS '(2 . -1) + (|specialChar| '|lrc|)) + NIL)))))))) + ((BOOT-EQUAL |kind| '|pi|) + (CONS (CONS '(0 . 1) (|specialChar| '|ulc|)) + (CONS (CONS '(1 . 0) (|specialChar| '|vbar|)) + (CONS (CONS '(1 . 1) + (|specialChar| '|ttee|)) + (CONS + (CONS '(1 . -1) + (|specialChar| '|vbar|)) + (CONS + (CONS '(2 . 1) + (|specialChar| '|hbar|)) + (CONS + (CONS '(3 . 0) + (|specialChar| '|vbar|)) + (CONS + (CONS '(3 . 1) + (|specialChar| '|ttee|)) + (CONS + (CONS '(3 . -1) + (|specialChar| '|vbar|)) + (CONS + (CONS '(4 . 1) + (|specialChar| '|urc|)) + NIL)))))))))) + ('T (THROW '|outputFailure| '|outputFailure|)))) + (|xLate| |opCode| (SPADDIFFERENCE |xCenter| |delta|) |y| |d|))))) + +;sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma) + +(DEFUN |sigmaWidth| (G168494) + (PROG (|bot| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR G168494)) + (SPADLET |arg| (CADDR G168494)) + (|bigopWidth| |bot| NIL |arg| '|sigma|))))) + +;sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma) + +(DEFUN |sigma2Width| (G168508) + (PROG (|bot| |top| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR G168508)) + (SPADLET |top| (CADDR G168508)) + (SPADLET |arg| (CADDDR G168508)) + (|bigopWidth| |bot| |top| |arg| '|sigma|))))) + +;sigma2Sub u == +; --The depth function for sigmas with 2 limits +; MAX(1 + height CADR u, subspan CADDDR u) + +(DEFUN |sigma2Sub| (|u|) + (MAX (PLUS 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) + +(DEFUN |sigma2Sup| (|u|) + (MAX (PLUS 1 (|height| (CADDR |u|))) (|superspan| (CADDDR |u|)))) + +;piSub u == +; --The depth function for pi's (products) +; MAX(1 + height CADR u, subspan CADDR u) + +(DEFUN |piSub| (|u|) + (MAX (PLUS 1 (|height| (CADR |u|))) (|subspan| (CADDR |u|)))) + +;piSup u == +; --The height function for pi's (products) +; MAX(1, superspan CADDR u) + +(DEFUN |piSup| (|u|) (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) + +(DEFUN |piApp| (|u| |x| |y| |d|) + (PROG (|ISTMP#1| |bot| |ISTMP#2| |arg|) + (RETURN + (PROGN + (OR (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |bot| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |arg| (QCAR |ISTMP#2|)) + 'T)))))) + (THROW '|outputFailure| '|outputFailure|)) + (|bigopAppAux| |bot| NIL |arg| |x| |y| |d| '|pi|))))) + +;piWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'pi) + +(DEFUN |piWidth| (G168561) + (PROG (|bot| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR G168561)) + (SPADLET |arg| (CADDR G168561)) + (|bigopWidth| |bot| NIL |arg| '|pi|))))) + +;pi2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'pi) + +(DEFUN |pi2Width| (G168575) + (PROG (|bot| |top| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR G168575)) + (SPADLET |top| (CADDR G168575)) + (SPADLET |arg| (CADDDR G168575)) + (|bigopWidth| |bot| |top| |arg| '|pi|))))) + +;pi2Sub u == +; --The depth function for pi's with 2 limits +; MAX(1 + height CADR u, subspan CADDDR u) + +(DEFUN |pi2Sub| (|u|) + (MAX (PLUS 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) + +(DEFUN |pi2Sup| (|u|) + (MAX (PLUS 1 (|height| (CADDR |u|))) (|superspan| (CADDDR |u|)))) + +;pi2App(u,x,y,d) == +; [.,bot,top,arg]:=u +; bigopAppAux(bot,top,arg,x,y,d,'pi) + +(DEFUN |pi2App| (|u| |x| |y| |d|) + (PROG (|bot| |top| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR |u|)) + (SPADLET |top| (CADDR |u|)) + (SPADLET |arg| (CADDDR |u|)) + (|bigopAppAux| |bot| |top| |arg| |x| |y| |d| '|pi|))))) + +;overlabelSuper [.,a,b] == 1 + height a + superspan b + +(DEFUN |overlabelSuper| (G168609) + (PROG (|a| |b|) + (RETURN + (PROGN + (SPADLET |a| (CADR G168609)) + (SPADLET |b| (CADDR G168609)) + (PLUS (PLUS 1 (|height| |a|)) (|superspan| |b|)))))) + +;overlabelWidth [.,a,b] == WIDTH b + +(DEFUN |overlabelWidth| (G168623) + (PROG (|a| |b|) + (RETURN + (PROGN + (SPADLET |a| (CADR G168623)) + (SPADLET |b| (CADDR G168623)) + (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,"|") + +(DEFUN |overlabelApp| (G168638 |x| |y| |d|) + (PROG (|a| |b| |underApp| |endPoint| |middle| |h|) + (RETURN + (PROGN + (SPADLET |a| (CADR G168638)) + (SPADLET |b| (CADDR G168638)) + (SPADLET |underApp| (APP |b| |x| |y| |d|)) + (SPADLET |endPoint| (SPADDIFFERENCE (PLUS |x| (WIDTH |b|)) 1)) + (SPADLET |middle| (QUOTIENT (PLUS |x| |endPoint|) 2)) + (SPADLET |h| (PLUS (PLUS |y| (|superspan| |b|)) 1)) + (SPADLET |d| (APP |a| |middle| (PLUS |h| 1) |d|)) + (|apphor| |x| (SPADDIFFERENCE (PLUS |x| (WIDTH |b|)) 1) + (PLUS (PLUS |y| (|superspan| |b|)) 1) |d| '|\||))))) + +;overbarSuper u == 1 + superspan u.1 + +(DEFUN |overbarSuper| (|u|) (PLUS 1 (|superspan| (ELT |u| 1)))) + +;overbarWidth u == WIDTH u.1 + +(DEFUN |overbarWidth| (|u|) (WIDTH (ELT |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) + +(DEFUN |overbarApp| (|u| |x| |y| |d|) + (PROG (|underApp|) + (RETURN + (PROGN + (SPADLET |underApp| (APP (ELT |u| 1) |x| |y| |d|)) + (|apphor| |x| (SPADDIFFERENCE (PLUS |x| (WIDTH (ELT |u| 1))) 1) + (PLUS (PLUS |y| (|superspan| (ELT |u| 1))) 1) |d| UNDERBAR))))) + +;indefIntegralSub u == +; -- form is INDEFINTEGRAL(expr,dx) +; MAX(1,subspan u.1,subspan u.2) + +(DEFUN |indefIntegralSub| (|u|) + (MAX 1 (|subspan| (ELT |u| 1)) (|subspan| (ELT |u| 2)))) + +;indefIntegralSup u == +; -- form is INDEFINTEGRAL(expr,dx) +; MAX(1,superspan u.1,superspan u.2) + +(DEFUN |indefIntegralSup| (|u|) + (MAX 1 (|superspan| (ELT |u| 1)) (|superspan| (ELT |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) + +(DEFUN |indefIntegralApp| (|u| |x| |y| |d|) + (PROG (|expr| |dx|) + (RETURN + (PROGN + (SPADLET |expr| (CADR |u|)) + (SPADLET |dx| (CADDR |u|)) + (SPADLET |d| (APP |expr| (PLUS |x| 4) |y| |d|)) + (SPADLET |d| + (APP |dx| (PLUS (PLUS |x| 5) (WIDTH |expr|)) |y| |d|)) + (|xLate| (CONS (CONS '(0 . -1) (|specialChar| '|llc|)) + (CONS (CONS '(1 . -1) (|specialChar| '|lrc|)) + (CONS (CONS '(1 . 0) + (|specialChar| '|vbar|)) + (CONS + (CONS '(1 . 1) + (|specialChar| '|ulc|)) + (CONS + (CONS '(2 . 1) + (|specialChar| '|urc|)) + NIL))))) + |x| |y| |d|))))) + +;indefIntegralWidth u == +; -- form is INDEFINTEGRAL(expr,dx) +; # u ^= 3 => THROW('outputFailure,'outputFailure) +; 5 + WIDTH u.1 + WIDTH u.2 + +(DEFUN |indefIntegralWidth| (|u|) + (COND + ((NEQUAL (|#| |u|) 3) (THROW '|outputFailure| '|outputFailure|)) + ('T (PLUS (PLUS 5 (WIDTH (ELT |u| 1))) (WIDTH (ELT |u| 2)))))) + +;intSub u == +; MAX(1 + height u.1, subspan u.3) + +(DEFUN |intSub| (|u|) + (MAX (PLUS 1 (|height| (ELT |u| 1))) (|subspan| (ELT |u| 3)))) + +;intSup u == +; MAX(1 + height u.2, superspan u.3) + +(DEFUN |intSup| (|u|) + (MAX (PLUS 1 (|height| (ELT |u| 2))) (|superspan| (ELT |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) + +(DEFUN |intApp| (|u| |x| |y| |d|) + (PROG (|bot| |top| |arg|) + (RETURN + (PROGN + (SPADLET |bot| (CADR |u|)) + (SPADLET |top| (CADDR |u|)) + (SPADLET |arg| (CADDDR |u|)) + (SPADLET |d| + (APP |arg| + (PLUS (PLUS |x| 4) + (MAX (PLUS (SPADDIFFERENCE 4) + (WIDTH |bot|)) + (WIDTH |top|))) + |y| |d|)) + (SPADLET |d| + (APP |bot| |x| + (SPADDIFFERENCE (SPADDIFFERENCE |y| 2) + (|superspan| |bot|)) + |d|)) + (SPADLET |d| + (APP |top| (PLUS |x| 3) + (PLUS (PLUS |y| 2) (|subspan| |top|)) |d|)) + (|xLate| (CONS (CONS '(0 . -1) (|specialChar| '|llc|)) + (CONS (CONS '(1 . -1) (|specialChar| '|lrc|)) + (CONS (CONS '(1 . 0) + (|specialChar| '|vbar|)) + (CONS + (CONS '(1 . 1) + (|specialChar| '|ulc|)) + (CONS + (CONS '(2 . 1) + (|specialChar| '|urc|)) + NIL))))) + |x| |y| |d|))))) + +;intWidth u == +; # u < 4 => THROW('outputFailure,'outputFailure) +; MAX(-4 + WIDTH u.1, WIDTH u.2) + WIDTH u.3 + 5 + +(DEFUN |intWidth| (|u|) + (COND + ((QSLESSP (|#| |u|) 4) (THROW '|outputFailure| '|outputFailure|)) + ('T + (PLUS (PLUS (MAX (PLUS (SPADDIFFERENCE 4) (WIDTH (ELT |u| 1))) + (WIDTH (ELT |u| 2))) + (WIDTH (ELT |u| 3))) + 5)))) + +;xLate(l,x,y,d) == +; for [[a,:b],:c] in l repeat +; d:= appChar(c,x+a,y+b,d) +; d + +(DEFUN |xLate| (|l| |x| |y| |d|) + (PROG (|a| |b| |c|) + (RETURN + (SEQ (PROGN + (DO ((G168723 |l| (CDR G168723)) (G168713 NIL)) + ((OR (ATOM G168723) + (PROGN (SETQ G168713 (CAR G168723)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAAR G168713)) + (SPADLET |b| (CDAR G168713)) + (SPADLET |c| (CDR G168713)) + G168713) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |d| + (|appChar| |c| (PLUS |x| |a|) + (PLUS |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 + +(DEFUN |concatTrouble,fixUp| (|x|) + (SEQ (IF (CDR |x|) + (EXIT (SEQ (IF |$addBlankIfTrue| (EXIT (CONS 'CONCATB |x|))) + (EXIT (CONS 'CONCAT |x|))))) + (EXIT (CAR |x|)))) + +(DEFUN |concatTrouble| (|u| |d| |start| |lineLength| |$addBlankIfTrue|) + (DECLARE (SPECIAL |$addBlankIfTrue|)) + (PROG (|LETTMP#1| |x| |l|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|splitConcat| |u| |lineLength| 'T)) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |l| (CDR |LETTMP#1|)) + (COND + ((NULL |l|) + (|sayALGEBRA| + (CONS '|%l| + (CONS '|%b| + (CONS (MAKESTRING + " Too wide to Print") + (CONS '|%d| NIL))))) + (THROW '|output| NIL)) + ('T + (|charybdis| (|concatTrouble,fixUp| |x|) |start| + |lineLength|) + (DO ((G168762 |l| (CDR G168762)) (|y| NIL)) + ((OR (ATOM G168762) + (PROGN (SETQ |y| (CAR G168762)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND (|d| (|prnd| |start| |d|))) + (COND + ((> |lineLength| 2) + (|charybdis| + (|concatTrouble,fixUp| |y|) + (PLUS |start| 2) + (SPADDIFFERENCE |lineLength| 2))) + ('T + (|charybdis| + (|concatTrouble,fixUp| |y|) + |start| 1))))))) + BLANK))))))) + +;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)] + +(DEFUN |splitConcat| (LIST |maxWidth| |firstTimeIfTrue|) + (PROG (|oneOrZero| |maxW| |width| |l| |totalWidth| |x|) + (RETURN + (SEQ (COND + ((NULL LIST) NIL) + ('T (SPADLET |totalWidth| 0) + (SPADLET |oneOrZero| (COND (|$addBlankIfTrue| 1) ('T 0))) + (SPADLET |l| LIST) + (SPADLET |maxW| + (COND + (|firstTimeIfTrue| |maxWidth|) + ('T (SPADDIFFERENCE |maxWidth| 2)))) + (COND + ((> 1 |maxW|) + (PROG (G168783) + (SPADLET G168783 NIL) + (RETURN + (DO ((G168788 |l| (CDR G168788)) (|x| NIL)) + ((OR (ATOM G168788) + (PROGN (SETQ |x| (CAR G168788)) NIL)) + (NREVERSE0 G168783)) + (SEQ (EXIT (SETQ G168783 + (CONS (CONS |x| NIL) G168783)))))))) + ('T + (DO ((|x| |l| (CDR |x|))) + ((OR (ATOM |x|) + (NULL (> |maxW| + (SPADLET |width| + (PLUS + (PLUS |oneOrZero| + (WIDTH (CAR |x|))) + |totalWidth|))))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |l| |x|) + (SPADLET |totalWidth| |width|))))) + (SPADLET |x| (CDR |l|)) (RPLAC (CDR |l|) NIL) + (CONS LIST (|splitConcat| |x| |maxWidth| NIL)))))))))) + +;spadPrint(x,m) == +; m = $NoValueMode => x +; if ^$collectOutput then TERPRI $algebraOutputStream +; output(x,m) +; if ^$collectOutput then TERPRI $algebraOutputStream + +(DEFUN |spadPrint| (|x| |m|) + (COND + ((BOOT-EQUAL |m| |$NoValueMode|) |x|) + ('T + (COND ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) + (|output| |x| |m|) + (COND + ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|)) + ('T NIL))))) + +;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 + +(DEFUN |formulaFormat| (|expr|) + (PROG (|sff| |formatFn| |displayFn|) + (RETURN + (PROGN + (SPADLET |sff| '(|ScriptFormulaFormat|)) + (SPADLET |formatFn| + (|getFunctionFromDomain| '|coerce| |sff| + (CONS |$OutputForm| NIL))) + (SPADLET |displayFn| + (|getFunctionFromDomain| '|display| |sff| + (CONS |sff| NIL))) + (SPADCALL (SPADCALL |expr| |formatFn|) |displayFn|) + (COND + ((NULL |$collectOutput|) (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 + +(DEFUN |texFormat| (|expr|) + (PROG (|tf| |formatFn| |displayFn|) + (RETURN + (PROGN + (SPADLET |tf| '(|TexFormat|)) + (SPADLET |formatFn| + (|getFunctionFromDomain| '|convert| |tf| + (CONS |$OutputForm| (CONS |$Integer| NIL)))) + (SPADLET |displayFn| + (|getFunctionFromDomain| '|display| |tf| + (CONS |tf| NIL))) + (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 + +(DEFUN |texFormat1| (|expr|) + (PROG (|tf| |formatFn| |displayFn|) + (RETURN + (PROGN + (SPADLET |tf| '(|TexFormat|)) + (SPADLET |formatFn| + (|getFunctionFromDomain| '|coerce| |tf| + (CONS |$OutputForm| NIL))) + (SPADLET |displayFn| + (|getFunctionFromDomain| '|display| |tf| + (CONS |tf| NIL))) + (SPADCALL (SPADCALL |expr| |formatFn|) |displayFn|) + (TERPRI |$texOutputStream|) + (FORCE-OUTPUT |$texOutputStream|) + NIL)))) + +;mathmlFormat expr == +; mml := '(MathMLFormat) +; mmlrep := '(String) +; formatFn := getFunctionFromDomain("coerce",mml,[$OutputForm]) +; displayFn := getFunctionFromDomain("display",mml,[mmlrep]) +; SPADCALL(SPADCALL(expr,formatFn),displayFn) +; TERPRI $mathmlOutputStream +; FORCE_-OUTPUT $mathmlOutputStream +; NIL + +(DEFUN |mathmlFormat| (|expr|) + (PROG (|mml| |mmlrep| |formatFn| |displayFn|) + (RETURN + (PROGN + (SPADLET |mml| '(|MathMLFormat|)) + (SPADLET |mmlrep| '(|String|)) + (SPADLET |formatFn| + (|getFunctionFromDomain| '|coerce| |mml| + (CONS |$OutputForm| NIL))) + (SPADLET |displayFn| + (|getFunctionFromDomain| '|display| |mml| + (CONS |mmlrep| NIL))) + (SPADCALL (SPADCALL |expr| |formatFn|) |displayFn|) + (TERPRI |$mathmlOutputStream|) + (FORCE-OUTPUT |$mathmlOutputStream|) + 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 +; if $mathmlFormat then mathmlFormat 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 +; if $mathmlFormat then mathmlFormat x +; (FUNCTIONP(opOf domain)) and (not (SYMBOLP(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"] + +(DEFUN |output| (|expr| |domain|) + (PROG (T$ |x| |printfun| |textwrit| |ISTMP#1| S) + (RETURN + (PROGN + (COND + ((|isWrapped| |expr|) (SPADLET |expr| (|unwrap| |expr|)))) + (COND + ((|isMapExpr| |expr|) + (COND (|$formulaFormat| (|formulaFormat| |expr|))) + (COND (|$texFormat| (|texFormat| |expr|))) + (COND (|$algebraFormat| (|mathprintWithNumber| |expr|))) + (COND (|$mathmlFormat| (|mathmlFormat| |expr|)) ('T NIL))) + ((OR (|categoryForm?| |domain|) + (|member| |domain| + '((|Mode|) (|Domain|) (|SubDomain| (|Domain|))))) + (COND + (|$algebraFormat| + (|mathprintWithNumber| + (|outputDomainConstructor| |expr|)))) + (COND + (|$texFormat| + (|texFormat| (|outputDomainConstructor| |expr|))) + ('T NIL))) + ((SPADLET T$ + (|coerceInteractive| (|objNewWrap| |expr| |domain|) + |$OutputForm|)) + (SPADLET |x| (|objValUnwrap| T$)) + (COND (|$formulaFormat| (|formulaFormat| |x|))) + (COND + (|$fortranFormat| (|dispfortexp| |x|) + (COND + ((NULL |$collectOutput|) + (TERPRI |$fortranOutputStream|))) + (FORCE-OUTPUT |$fortranOutputStream|))) + (COND (|$algebraFormat| (|mathprintWithNumber| |x|))) + (COND (|$texFormat| (|texFormat| |x|))) + (COND (|$mathmlFormat| (|mathmlFormat| |x|)) ('T NIL))) + ((AND (FUNCTIONP (|opOf| |domain|)) + (NULL (SYMBOLP (|opOf| |domain|))) + (SPADLET |printfun| + (|compiledLookup| '<< + '(|TextWriter| |TextWriter| $) + (|evalDomain| |domain|))) + (SPADLET |textwrit| + (|compiledLookup| '|print| '($) + (|TextWriter|)))) + (|sayMSGNT| + (APPEND (|bright| (MAKESTRING "AXIOM-XL")) + (CONS (MAKESTRING "output: ") NIL))) + (SPADCALL (SPADCALL |textwrit|) |expr| |printfun|) + (|sayMSGNT| '|%l|)) + ((AND (PAIRP |domain|) (EQ (QCAR |domain|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |domain|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) 'T)))) + (|output| (|asTupleAsList| |expr|) + (CONS '|List| (CONS S NIL)))) + ('T + (|sayALGEBRA| + (APPEND (|bright| (MAKESTRING "LISP")) + (CONS (MAKESTRING "output:") + (CONS '|%l| + (CONS (OR |expr| (MAKESTRING "NIL")) + 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] + +(DEFUN |outputNumber| (|start| |linelength| |num|) + (PROG (|under| |blnks| |firsttime|) + (RETURN + (SEQ (PROGN + (COND + ((> |start| 1) + (SPADLET |blnks| + (|fillerSpaces| (SPADDIFFERENCE |start| 1) + (MAKESTRING " ")))) + ('T (SPADLET |blnks| (MAKESTRING "")))) + (SPADLET |under| (MAKESTRING "_")) + (SPADLET |firsttime| (> |linelength| 3)) + (COND + ((> |linelength| 2) + (SPADLET |linelength| (SPADDIFFERENCE |linelength| 1)))) + (DO () ((NULL (> (SIZE |num|) |linelength|)) NIL) + (SEQ (EXIT (PROGN + (COND + (|$collectOutput| + (SPADLET |$outputLines| + (CONS + (CONCAT |blnks| + (SUBSTRING |num| 0 + |linelength|) + |under|) + |$outputLines|))) + ('T + (|sayALGEBRA| + (CONS |blnks| + (CONS + (SUBSTRING |num| 0 |linelength|) + (CONS |under| NIL)))))) + (SPADLET |num| + (SUBSTRING |num| |linelength| NIL)) + (COND + (|firsttime| + (SPADLET |blnks| + (CONCAT |blnks| + (MAKESTRING " "))) + (SPADLET |linelength| + (SPADDIFFERENCE |linelength| + 1)) + (SPADLET |firsttime| NIL)) + ('T NIL)))))) + (COND + (|$collectOutput| + (SPADLET |$outputLines| + (CONS (CONCAT |blnks| |num|) + |$outputLines|))) + ('T (|sayALGEBRA| (CONS |blnks| (CONS |num| NIL)))))))))) + +;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] + +(DEFUN |outputString| (|start| |linelength| |str|) + (PROG (|blnks|) + (RETURN + (SEQ (PROGN + (COND + ((> |start| 1) + (SPADLET |blnks| + (|fillerSpaces| (SPADDIFFERENCE |start| 1) + (MAKESTRING " ")))) + ('T (SPADLET |blnks| (MAKESTRING "")))) + (DO () ((NULL (> (SIZE |str|) |linelength|)) NIL) + (SEQ (EXIT (PROGN + (COND + (|$collectOutput| + (SPADLET |$outputLines| + (CONS + (CONCAT |blnks| + (SUBSTRING |str| 0 + |linelength|)) + |$outputLines|))) + ('T + (|sayALGEBRA| + (CONS |blnks| + (CONS + (SUBSTRING |str| 0 |linelength|) + NIL))))) + (SPADLET |str| + (SUBSTRING |str| |linelength| NIL)))))) + (COND + (|$collectOutput| + (SPADLET |$outputLines| + (CONS (CONCAT |blnks| |str|) + |$outputLines|))) + ('T (|sayALGEBRA| (CONS |blnks| (CONS |str| NIL)))))))))) + +;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] + +(DEFUN |outputDomainConstructor| (|form|) + (PROG (|u| |v|) + (RETURN + (SEQ (PROGN + (COND + ((VECTORP (CAR |form|)) + (SPADLET |form| (|devaluate| |form|)))) + (COND + ((ATOM (SPADLET |u| (|prefix2String| |form|))) |u|) + ('T + (SPADLET |v| + (PROG (G168919) + (SPADLET G168919 NIL) + (RETURN + (DO ((G168924 |u| (CDR G168924)) + (|x| NIL)) + ((OR (ATOM G168924) + (PROGN + (SETQ |x| (CAR G168924)) + NIL)) + (NREVERSE0 G168919)) + (SEQ (EXIT + (SETQ G168919 + (CONS (|object2String| |x|) + G168919)))))))) + (RETURN (INTERNL (|eval| (CONS '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 + +(DEFUN |getOutputAbbreviatedForm| (|form|) + (PROG (|op| |u| |ml| |x'| |argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + 'T)) + (COND + ((|member| |op| '(|Union| |Record|)) + (|outputDomainConstructor| |form|)) + ((EQ |op| '|Mapping|) (|formatMapping| |argl|)) + ('T (SPADLET |u| (OR (|constructor?| |op|) |op|)) + (COND + ((NULL |argl|) |u|) + ('T + (SPADLET |ml| + (|getPartialConstructorModemapSig| |op|)) + (SPADLET |argl| + (PROG (G168949) + (SPADLET G168949 NIL) + (RETURN + (DO ((G168955 |argl| + (CDR G168955)) + (|x| NIL) + (G168956 |ml| (CDR G168956)) + (|m| NIL)) + ((OR (ATOM G168955) + (PROGN + (SETQ |x| (CAR G168955)) + NIL) + (ATOM G168956) + (PROGN + (SETQ |m| (CAR G168956)) + NIL)) + (NREVERSE0 G168949)) + (SEQ + (EXIT + (SETQ G168949 + (CONS + (COND + ((|categoryForm?| |m|) + (|outputDomainConstructor| + |x|)) + ('T + (SPADLET |x'| + (|coerceInteractive| + (|objNewWrap| |x| |m|) + |$OutputForm|)) + (COND + (|x'| + (|objValUnwrap| |x'|)) + ('T + (MAKESTRING + "unprintableObject"))))) + G168949)))))))) + (CONS |u| |argl|)))))) + ('T |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 + +(DEFUN |outputOp| (|x|) + (PROG (|op| |args| |n| |newop|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |args| (QCDR |x|)) + 'T) + (OR (GETL |op| 'LED) (GETL |op| 'NUD))) + (SPADLET |n| + (COND ((GETL |op| 'NARY) 2) ('T (|#| |args|)))) + (SPADLET |newop| + (INTERN (STRCONC '* (STRINGIMAGE |n|) + (PNAME |op|)))) + (CONS |newop| + (PROG (G168985) + (SPADLET G168985 NIL) + (RETURN + (DO ((G168990 |args| (CDR G168990)) + (|y| NIL)) + ((OR (ATOM G168990) + (PROGN + (SETQ |y| (CAR G168990)) + NIL)) + (NREVERSE0 G168985)) + (SEQ (EXIT (SETQ G168985 + (CONS (|outputOp| |y|) G168985))))))))) + ('T |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 + +(DEFUN |printMap| (|u|) + (PROG (|initialFlag| |x| |l| |ISTMP#1| |n|) + (RETURN + (SEQ (PROGN + (|printBasic| (|specialChar| '|lbrk|)) + (SPADLET |initialFlag| (|isInitialMap| |u|)) + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |x| (QCAR |u|)) + (SPADLET |l| (QCDR |u|)) + 'T)) + (|printMap1| |x| + (AND |initialFlag| (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + 'T))) + (EQL |n| 1))) + (DO ((G169019 |l| (CDR G169019)) (|y| NIL)) + ((OR (ATOM G169019) + (PROGN (SETQ |y| (CAR G169019)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|printBasic| '| , |) + (|printMap1| |y| |initialFlag|))))))) + (|printBasic| (|specialChar| '|rbrk|)) + (COND + ((NULL |$collectOutput|) + (TERPRI |$algebraOutputStream|)) + ('T NIL))))))) + +;isInitialMap u == +; u is [[[n],.],:l] and INTEGERP n and +; (and/[x is [[ =i],.] for x in l for i in n+1..]) + +(DEFUN |isInitialMap| (|u|) + (PROG (|n| |ISTMP#3| |l| |ISTMP#1| |ISTMP#2|) + (RETURN + (SEQ (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |n| (QCAR |ISTMP#2|)) + 'T))) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL))))) + (PROGN (SPADLET |l| (QCDR |u|)) 'T) (INTEGERP |n|) + (PROG (G169051) + (SPADLET G169051 'T) + (RETURN + (DO ((G169062 NIL (NULL G169051)) + (G169063 |l| (CDR G169063)) (|x| NIL) + (|i| (PLUS |n| 1) (+ |i| 1))) + ((OR G169062 (ATOM G169063) + (PROGN (SETQ |x| (CAR G169063)) NIL)) + G169051) + (SEQ (EXIT (SETQ G169051 + (AND G169051 + (AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) + |i|))) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |x|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL)))))))))))))))) + +;printMap1(x,initialFlag) == +; initialFlag => printBasic CADR x +; if CDAR x then printBasic first x else printBasic CAAR x +; printBasic " E " +; printBasic CADR x + +(DEFUN |printMap1| (|x| |initialFlag|) + (COND + (|initialFlag| (|printBasic| (CADR |x|))) + ('T + (COND + ((CDAR |x|) (|printBasic| (CAR |x|))) + ('T (|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) + +(DEFUN |printBasic| (|x|) + (COND + ((BOOT-EQUAL |x| '(|One|)) (PRIN1 1 |$algebraOutputStream|)) + ((BOOT-EQUAL |x| '(|Zero|)) (PRIN1 0 |$algebraOutputStream|)) + ((IDENTP |x|) (PRINTEXP (PNAME |x|) |$algebraOutputStream|)) + ((ATOM |x|) (PRIN1 |x| |$algebraOutputStream|)) + ('T (PRIN0 |x| |$algebraOutputStream|)))) + +;charybdis(u,start,linelength) == +; EQ(keyp u,'EQUATNUM) and ^(CDDR u) => +; charybdis(['PAREN,u.1],start,linelength) +; charyTop(u,start,linelength) + +(DEFUN |charybdis| (|u| |start| |linelength|) + (COND + ((AND (EQ (|keyp| |u|) 'EQUATNUM) (NULL (CDDR |u|))) + (|charybdis| (CONS 'PAREN (CONS (ELT |u| 1) NIL)) |start| + |linelength|)) + ('T (|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 +; '" " + +(DEFUN |charyTop| (|u| |start| |linelength|) + (PROG (|ISTMP#2| |ISTMP#3| |ISTMP#4| |ISTMP#5| |l| |ISTMP#1| |a| |b| + |w| |v| |d| |m| |n|) + (RETURN + (SEQ (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) 'SC) + (PROGN (SPADLET |l| (QCDR |u|)) 'T)) + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'SC))) + (PROGN (SPADLET |l| (QCDR |u|)) 'T))) + (DO ((G169131 |l| (CDR G169131)) (|a| NIL)) + ((OR (ATOM G169131) + (PROGN (SETQ |a| (CAR G169131)) NIL)) + NIL) + (SEQ (EXIT (|charyTop| |a| |start| |linelength|)))) + (MAKESTRING " ")) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'CONCATB))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |u|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (REVERSE |ISTMP#2|)) + 'T) + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| (QCAR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |ISTMP#5| (QCAR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCAR |ISTMP#5|) 'SC))) + (PROGN + (SPADLET |l| (QCDR |ISTMP#4|)) + 'T))) + (PROGN (SPADLET |m| (QCDR |ISTMP#3|)) 'T) + (PROGN (SPADLET |m| (NREVERSE |m|)) 'T)))) + (|charyTop| (CONS 'CONCATB |m|) |start| |linelength|) + (|charyTop| (CONS 'SC |l|) (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'CENTER) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |b| (|charyTopWidth| |a|)) + (COND + ((> (SPADLET |w| (WIDTH |b|)) + (SPADDIFFERENCE |linelength| |start|)) + (|charyTop| |a| |start| |linelength|)) + ('T + (|charyTop| |b| + (QUOTIENT + (SPADDIFFERENCE + (SPADDIFFERENCE |linelength| |start|) |w|) + 2) + |linelength|)))) + ('T (SPADLET |v| (|charyTopWidth| |u|)) + (COND + ((EQ (|keyp| |u|) 'ELSE) + (|charyElse| |u| |v| |start| |linelength|)) + ((> (WIDTH |v|) |linelength|) + (|charyTrouble| |u| |v| |start| |linelength|)) + ('T (SPADLET |d| (APP |v| |start| 0 NIL)) + (SPADLET |n| (|superspan| |v|)) + (SPADLET |m| (SPADDIFFERENCE (|subspan| |v|))) + (COND + (|$testOutputLineFlag| + (SPADLET |$testOutputLineList| + (APPEND (ASSOCRIGHT (SORTBY 'CAR |d|)) + |$testOutputLineList|))) + ('T + (DO ((G169142 NIL (> |m| |n|))) (G169142 NIL) + (SEQ (EXIT (PROGN + (|scylla| |n| |d|) + (SPADLET |n| (SPADDIFFERENCE |n| 1)))))) + (MAKESTRING " "))))))))))) + +;charyTopWidth u == +; atom u => u +; atom first u => putWidth u +; NUMBERP CDAR u => u +; putWidth u + +(DEFUN |charyTopWidth| (|u|) + (COND + ((ATOM |u|) |u|) + ((ATOM (CAR |u|)) (|putWidth| |u|)) + ((NUMBERP (CDAR |u|)) |u|) + ('T (|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) + +(DEFUN |charyTrouble| (|u| |v| |start| |linelength|) + (PROG (|al|) + (RETURN + (COND + ((SPADLET |al| + (|LargeMatrixp| |u| |linelength| + (TIMES 2 |linelength|))) + (SPADLET |u| (|SubstWhileDesizing| |u| NIL)) + (|maprinChk| |u|)) + ('T (|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 + +(DEFUN |sublisMatAlist| (|m| |m1| |u|) + (PROG (|op| |r| |op1| |r1|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |r| (QCDR |u|)) + 'T)) + (COND + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'MATRIX) + (BOOT-EQUAL |u| |m|)) + |m1|) + ('T (SPADLET |op1| (|sublisMatAlist| |m| |m1| |op|)) + (SPADLET |r1| + (PROG (G169190) + (SPADLET G169190 NIL) + (RETURN + (DO ((G169195 |r| (CDR G169195)) + (|s| NIL)) + ((OR (ATOM G169195) + (PROGN + (SETQ |s| (CAR G169195)) + NIL)) + (NREVERSE0 G169190)) + (SEQ (EXIT + (SETQ G169190 + (CONS + (|sublisMatAlist| |m| |m1| |s|) + G169190)))))))) + (COND + ((AND (BOOT-EQUAL |op| |op1|) (BOOT-EQUAL |r1| |r|)) + |u|) + ('T (CONS |op1| |r1|)))))) + ('T |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 +; '" " + +(DEFUN |charyTrouble1| (|u| |v| |start| |linelength|) + (PROG (|x| |d| |wu| |loop| |ISTMP#4| |body| |ISTMP#1| |ISTMP#2| |wu'| + |ISTMP#3|) + (RETURN + (COND + ((NUMBERP |u|) + (|outputNumber| |start| |linelength| (|atom2String| |u|))) + ((ATOM |u|) + (|outputString| |start| |linelength| (|atom2String| |u|))) + ((EQ (SPADLET |x| (|keyp| |u|)) '-) + (|charyMinus| |u| |v| |start| |linelength|)) + ((MEMQ |x| '(+ * AGGLST)) + (|charySplit| |u| |v| |start| |linelength|)) + ((EQ |x| 'EQUATNUM) + (|charyEquatnum| |u| |v| |start| |linelength|)) + ((SPADLET |d| (GETL |x| 'INFIXOP)) + (|charyBinary| |d| |u| |v| |start| |linelength|)) + ((BOOT-EQUAL |x| 'OVER) + (|charyBinary| (GETL '/ 'INFIXOP) |u| |v| |start| + |linelength|)) + ((AND (EQ 3 (LENGTH |u|)) (GETL |x| '|Led|)) + (SPADLET |d| (PNAME (CAR (GETL |x| '|Led|)))) + (|charyBinary| |d| |u| |v| |start| |linelength|)) + ((EQ |x| 'CONCAT) + (|concatTrouble| (CDR |v|) |d| |start| |linelength| NIL)) + ((EQ |x| 'CONCATB) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CDR |v|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |loop| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|repeat|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#3|)) + 'T))))))) + (|charyTop| + (CONS 'CONCATB (CONS |loop| (CONS '|repeat| NIL))) + |start| |linelength|) + (|charyTop| |body| (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2))) + ((AND (PROGN + (SPADLET |ISTMP#1| (CDR |v|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |wu| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |loop| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|repeat|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#4|)) + 'T))))))))) + (PROGN + (SPADLET |ISTMP#1| (|keyp| |wu|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'CONCATB) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |wu'| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL))))))) + (|member| |wu'| '(|while| |until|))) + (|charyTop| + (CONS 'CONCATB + (CONS |wu| (CONS |loop| (CONS '|repeat| NIL)))) + |start| |linelength|) + (|charyTop| |body| (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2))) + ('T (|concatTrouble| (CDR |v|) |d| |start| |linelength| 'T)))) + ((GETL |x| 'INFIXOP) + (|charySplit| |u| |v| |start| |linelength|)) + ((AND (EQ |x| 'PAREN) + (OR (AND (EQ (|keyp| (ELT |u| 1)) 'AGGLST) + (SPADLET |v| '|,|)) + (AND (EQ (|keyp| (ELT |u| 1)) 'AGGSET) + (SPADLET |v| '|;|)))) + (|bracketagglist| (CDR (ELT |u| 1)) |start| |linelength| |v| + '|(| '|)|)) + ((AND (EQ |x| 'PAREN) (EQ (|keyp| (ELT |u| 1)) 'CONCATB)) + (|bracketagglist| (CDR (ELT |u| 1)) |start| |linelength| '| | + '|(| '|)|)) + ((AND (EQ |x| 'BRACKET) (EQ (|keyp| (ELT |u| 1)) 'AGGLST) + (SPADLET |v| '|,|)) + (|bracketagglist| (CDR (ELT |u| 1)) |start| |linelength| |v| + (|specialChar| '|lbrk|) (|specialChar| '|rbrk|))) + ((AND (EQ |x| 'BRACE) (EQ (|keyp| (ELT |u| 1)) 'AGGLST) + (SPADLET |v| '|,|)) + (|bracketagglist| (CDR (ELT |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|)) + ('T (|charybdis| |x| |start| |linelength|) + (COND + ((CDR |u|) + (|charybdis| (CONS 'ELSE (CDR |u|)) |start| |linelength|))) + (MAKESTRING " ")))))) + +;charySemiColon(u,v,start,linelength) == +; for a in rest u repeat +; charyTop(a,start,linelength) +; nil + +(DEFUN |charySemiColon| (|u| |v| |start| |linelength|) + (SEQ (PROGN + (DO ((G169335 (CDR |u|) (CDR G169335)) (|a| NIL)) + ((OR (ATOM G169335) + (PROGN (SETQ |a| (CAR G169335)) NIL)) + NIL) + (SEQ (EXIT (|charyTop| |a| |start| |linelength|)))) + NIL))) + +;charyMinus(u,v,start,linelength) == +; charybdis('"-",start,linelength) +; charybdis(v.1,start+3,linelength-3) +; '" " + +(DEFUN |charyMinus| (|u| |v| |start| |linelength|) + (PROGN + (|charybdis| (MAKESTRING "-") |start| |linelength|) + (|charybdis| (ELT |v| 1) (PLUS |start| 3) + (SPADDIFFERENCE |linelength| 3)) + (MAKESTRING " "))) + +;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) +; '" " + +(DEFUN |charyBinary| (|d| |u| |v| |start| |linelength|) + (COND + ((|member| |d| '(" := " "= ")) + (|charybdis| (CONS 'CONCATB (CONS (ELT |v| 1) (CONS |d| NIL))) + |start| |linelength|) + (|charybdis| (ELT |v| 2) (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2)) + (MAKESTRING " ")) + ('T + (|charybdis| (ELT |v| 1) (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2)) + (COND (|d| (|prnd| |start| |d|))) + (|charybdis| (ELT |v| 2) (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2)) + (MAKESTRING " ")))) + +;charyEquatnum(u,v,start,linelength) == +; charybdis(['PAREN,u.1],start,linelength) +; charybdis(u.2,start,linelength) +; '" " + +(DEFUN |charyEquatnum| (|u| |v| |start| |linelength|) + (PROGN + (|charybdis| (CONS 'PAREN (CONS (ELT |u| 1) NIL)) |start| + |linelength|) + (|charybdis| (ELT |u| 2) |start| |linelength|) + (MAKESTRING " "))) + +;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) + +(DEFUN |charySplit| (|u| |v| |start| |linelength|) + (PROG (|dm| |ddm| |m|) + (RETURN + (SEQ (PROGN + (SPADLET |v| (CONS (CAR (ELT |v| 0)) (CDR |v|))) + (SPADLET |m| (CDR |v|)) + (COND + ((> (WIDTH (ELT |v| 1)) (SPADDIFFERENCE |linelength| 2)) + (|charybdis| (ELT |v| 1) (PLUS |start| 2) + (SPADDIFFERENCE |linelength| 2)) + (COND + ((NULL (CDDR |v|)) (MAKESTRING " ")) + ('T (SPADLET |dm| (CDDR |v|)) + (SPADLET |ddm| (CDR |dm|)) + (|split2| |u| |dm| |ddm| |start| |linelength|)))) + ('T + (DO ((|i| 0 (QSADD1 |i|))) (NIL NIL) + (SEQ (EXIT (PROGN + (SPADLET |dm| (CDR |m|)) + (SPADLET |ddm| (CDR |dm|)) + (RPLACD |dm| NIL) + (COND + ((> (WIDTH |v|) + (SPADDIFFERENCE |linelength| 2)) + (RETURN NIL)) + ('T + (RPLAC (CAR |v|) (CAR (ELT |v| 0))) + (RPLACD |dm| |ddm|) + (SPADLET |m| (CDR |m|)))))))) + (RPLAC (CAR |v|) (CAR (ELT |v| 0))) (RPLACD |m| NIL) + (|charybdis| |v| (PLUS |start| 2) + (SPADDIFFERENCE |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] start+2; start),(m => linelength-2; linelength)) +; '" " + +(DEFUN |split2| (|u| |dm| |ddm| |start| |linelength|) + (PROG (|d| |m|) + (RETURN + (PROGN + (|prnd| |start| + (COND + ((SPADLET |d| (GETL (|keyp| |u|) 'INFIXOP)) |d|) + ('T (MAKESTRING ",")))) + (RPLACD |dm| |ddm|) + (SPADLET |m| + (> (SPADDIFFERENCE |linelength| 2) + (WIDTH (CONS (|keyp| |u|) |dm|)))) + (|charybdis| (CONS (|keyp| |u|) |dm|) + (COND (|m| (PLUS |start| 2)) ('T |start|)) + (COND + (|m| (SPADDIFFERENCE |linelength| 2)) + ('T |linelength|))) + (MAKESTRING " "))))) + +;charyElse(u,v,start,linelength) == +; charybdis(v.1,start+3,linelength-3) +; ^(CDDR u) => '" " +; prnd(start,'",") +; charybdis(['ELSE,:CDDR v],start,linelength) +; '" " + +(DEFUN |charyElse| (|u| |v| |start| |linelength|) + (PROGN + (|charybdis| (ELT |v| 1) (PLUS |start| 3) + (SPADDIFFERENCE |linelength| 3)) + (COND + ((NULL (CDDR |u|)) (MAKESTRING " ")) + ('T (|prnd| |start| (MAKESTRING ",")) + (|charybdis| (CONS 'ELSE (CDDR |v|)) |start| |linelength|) + (MAKESTRING " "))))) + +;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 + +(DEFUN |scylla| (|n| |v|) + (PROG (|y|) + (RETURN + (PROGN + (SPADLET |y| (LASSOC |n| |v|)) + (COND + ((NULL |y|) NIL) + ('T + (COND + ((STRINGP |y|) + (SPADLET |y| (DROPTRAILINGBLANKS (COPY |y|))))) + (COND + (|$collectOutput| + (SPADLET |$outputLines| (CONS |y| |$outputLines|))) + ('T (PRINTEXP |y| |$algebraOutputStream|) + (TERPRI |$algebraOutputStream|))) + NIL)))))) + +;keyp(u) == +; atom u => nil +; atom first u => first u +; CAAR u + +(DEFUN |keyp| (|u|) + (COND ((ATOM |u|) NIL) ((ATOM (CAR |u|)) (CAR |u|)) ('T (CAAR |u|)))) + +;absym x == +; (NUMBERP x) and (MINUSP x) => -x +; ^(atom x) and (keyp(x) = '_-) => CADR x +; x + +(DEFUN |absym| (|x|) + (COND + ((AND (NUMBERP |x|) (MINUSP |x|)) (SPADDIFFERENCE |x|)) + ((AND (NULL (ATOM |x|)) (BOOT-EQUAL (|keyp| |x|) '-)) (CADR |x|)) + ('T |x|))) + +;agg(n,u) == +; (n = 1) => CADR u +; agg(n - 1, rest u) + +(DEFUN |agg| (|n| |u|) + (COND + ((EQL |n| 1) (CADR |u|)) + ('T (|agg| (SPADDIFFERENCE |n| 1) (CDR |u|))))) + +;aggwidth u == +; null u => 0 +; null rest u => WIDTH first u +; 1 + (WIDTH first u) + (aggwidth rest u) + +(DEFUN |aggwidth| (|u|) + (COND + ((NULL |u|) 0) + ((NULL (CDR |u|)) (WIDTH (CAR |u|))) + ('T (PLUS (PLUS 1 (WIDTH (CAR |u|))) (|aggwidth| (CDR |u|)))))) + +;argsapp(u,x,y,d) == appargs(rest u,x,y,d) + +(DEFUN |argsapp| (|u| |x| |y| |d|) (|appargs| (CDR |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) + +(DEFUN |subspan| (|u|) + (COND + ((ATOM |u|) 0) + ((NUMBERP (CDR |u|)) (|subspan| (CAR |u|))) + ((AND (NULL (ATOM (CAR |u|))) (ATOM (CAAR |u|)) + (NULL (NUMBERP (CAAR |u|))) (GETL (CAAR |u|) 'SUBSPAN)) + (APPLX (GETL (CAAR |u|) 'SUBSPAN) (LIST |u|))) + ('T (MAX (|subspan| (CAR |u|)) (|subspan| (CDR |u|)))))) + +;agggsub u == subspan rest u + +(DEFUN |agggsub| (|u|) (|subspan| (CDR |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) + +(DEFUN |superspan| (|u|) + (COND + ((ATOM |u|) 0) + ((NUMBERP (CDR |u|)) (|superspan| (CAR |u|))) + ((AND (NULL (ATOM (CAR |u|))) (ATOM (CAAR |u|)) + (NULL (NUMBERP (CAAR |u|))) (GETL (CAAR |u|) 'SUPERSPAN)) + (APPLX (GETL (CAAR |u|) 'SUPERSPAN) (LIST |u|))) + ('T (MAX (|superspan| (CAR |u|)) (|superspan| (CDR |u|)))))) + +;agggsuper u == superspan rest u + +(DEFUN |agggsuper| (|u|) (|superspan| (CDR |u|))) + +;agggwidth u == aggwidth rest u + +(DEFUN |agggwidth| (|u|) (|aggwidth| (CDR |u|))) + +;appagg(u,x,y,d) == appagg1(u,x,y,d,'",") + +(DEFUN |appagg| (|u| |x| |y| |d|) + (|appagg1| |u| |x| |y| |d| (MAKESTRING ","))) + +;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) + +(DEFUN |appagg1| (|u| |x| |y| |d| |s|) + (PROG (|temp| |temparg1| |temparg2|) + (RETURN + (COND + ((NULL |u|) |d|) + ((NULL (CDR |u|)) (APP (CAR |u|) |x| |y| |d|)) + ('T (SPADLET |temp| (PLUS |x| (WIDTH (CAR |u|)))) + (SPADLET |temparg1| (APP (CAR |u|) |x| |y| |d|)) + (SPADLET |temparg2| (APP |s| |temp| |y| |temparg1|)) + (|appagg1| (CDR |u|) (PLUS 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,'";") + +(DEFUN |appargs| (|u| |x| |y| |d|) + (|appargs1| |u| |x| |y| |d| (MAKESTRING ";"))) + +;--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) + +(DEFUN |appargs1| (|u| |x| |y| |d| |s|) + (PROG (|temp| |temparg1| |temparg2|) + (RETURN + (COND + ((NULL |u|) |d|) + ((NULL (CDR |u|)) (APP (CAR |u|) |x| |y| |d|)) + ('T (SPADLET |temp| (PLUS |x| (WIDTH (CAR |u|)))) + (SPADLET |temparg1| (APP (CAR |u|) |x| |y| |d|)) + (SPADLET |temparg2| (APP |s| |temp| |y| |temparg1|)) + (|appargs| (CDR |u|) (PLUS 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)) + +(DEFUN |apprpar| (|x| |y| |y1| |y2| |d|) + (COND + ((OR (NULL *TALLPAR) (> 2 (SPADDIFFERENCE |y2| |y1|))) + (APP (MAKESTRING ")") |x| |y| |d|)) + ('T + (APP (MAKESTRING ")") |x| |y2| + (|apprpar1| |x| |y| |y1| (SPADDIFFERENCE |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)) + +(DEFUN |apprpar1| (|x| |y| |y1| |y2| |d|) + (COND + ((BOOT-EQUAL |y1| |y2|) (APP (MAKESTRING ")") |x| |y2| |d|)) + ('T + (APP (MAKESTRING ")") |x| |y2| + (|apprpar1| |x| |y| |y1| (SPADDIFFERENCE |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)) + +(DEFUN |applpar| (|x| |y| |y1| |y2| |d|) + (COND + ((OR (NULL *TALLPAR) (> 2 (SPADDIFFERENCE |y2| |y1|))) + (APP (MAKESTRING "(") |x| |y| |d|)) + ('T + (APP (MAKESTRING "(") |x| |y2| + (|applpar1| |x| |y| |y1| (SPADDIFFERENCE |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)) + +(DEFUN |applpar1| (|x| |y| |y1| |y2| |d|) + (COND + ((BOOT-EQUAL |y1| |y2|) (APP (MAKESTRING "(") |x| |y2| |d|)) + ('T + (APP (MAKESTRING "(") |x| |y2| + (|applpar1| |x| |y| |y1| (SPADDIFFERENCE |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) + +(DEFUN |appelse| (|u| |x| |y| |d|) + (PROG (|w| |b| |p| |temparg1| |temparg2| |temparg3|) + (RETURN + (PROGN + (SPADLET |w| (WIDTH (CAAR |u|))) + (SPADLET |b| (SPADDIFFERENCE |y| (|subspan| (CDR |u|)))) + (SPADLET |p| (PLUS |y| (|superspan| (CDR |u|)))) + (SPADLET |temparg1| (APP (|keyp| |u|) |x| |y| |d|)) + (SPADLET |temparg2| + (|applpar| (PLUS |x| |w|) |y| |b| |p| |temparg1|)) + (SPADLET |temparg3| + (|appagg| (CDR |u|) (PLUS (PLUS |x| 1) |w|) |y| + |temparg2|)) + (|apprpar| + (PLUS (PLUS (PLUS |x| 1) |w|) (|aggwidth| (CDR |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) + +(DEFUN |appext| (|u| |x| |y| |d|) + (PROG (|xptr| |yptr| |temp| |z| |n|) + (RETURN + (PROGN + (SPADLET |xptr| |x|) + (SPADLET |yptr| + (SPADDIFFERENCE |y| + (PLUS (PLUS (|subspan| (CADR |u|)) + (|superspan| (|agg| 3 |u|))) + 1))) + (SPADLET |d| (APP (CADR |u|) |x| |y| |d|)) + (SPADLET |d| (APP (|agg| 2 |u|) |xptr| |yptr| |d|)) + (SPADLET |xptr| (PLUS |xptr| (WIDTH (|agg| 2 |u|)))) + (SPADLET |d| (APP (MAKESTRING "=") |xptr| |yptr| |d|)) + (SPADLET |d| (APP (|agg| 3 |u|) (PLUS 1 |xptr|) |yptr| |d|)) + (SPADLET |yptr| + (PLUS (PLUS (PLUS |y| 1) (|superspan| (CADR |u|))) + (SUBSPAD (|agg| 4 |u|)))) + (SPADLET |d| (APP (|agg| 4 |u|) |x| |yptr| |d|)) + (SPADLET |temp| + (PLUS (PLUS 1 (WIDTH (|agg| 2 |u|))) + (WIDTH (|agg| 3 |u|)))) + (SPADLET |n| + (MAX (WIDTH (CADR |u|)) (WIDTH (|agg| 4 |u|)) |temp|)) + (COND + ((AND (EQCAR (CAR (SPADLET |z| (|agg| 5 |u|))) 'EXT) + (OR (EQ |n| 3) (AND (> |n| 3) (NULL (ATOM |z|))))) + (SPADLET |n| (PLUS 1 |n|)))) + (SPADLET |d| (APP |z| (PLUS |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) + +(DEFUN |apphor| (|x1| |x2| |y| |d| |char|) + (PROG (|temp|) + (RETURN + (PROGN + (SPADLET |temp| + (COND + ((BOOT-EQUAL |x1| |x2|) |d|) + ('T + (|apphor| |x1| (SPADDIFFERENCE |x2| 1) |y| |d| + |char|)))) + (APP |char| |x2| |y| |temp|))))) + +;syminusp x == +; NUMBERP x => MINUSP x +; ^(atom x) and EQ(keyp x,'_-) + +(DEFUN |syminusp| (|x|) + (COND + ((NUMBERP |x|) (MINUSP |x|)) + ('T (AND (NULL (ATOM |x|)) (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) + +(DEFUN |appsum| (|u| |x| |y| |d|) + (PROG (|ac| |sc| |dp| |tempx| |temparg1| |bot| |top| |temparg2| + |temparg3| |tempdblock|) + (RETURN + (COND + ((NULL |u|) |d|) + ('T (SPADLET |ac| (|absym| (CAR |u|))) + (SPADLET |sc| + (COND + ((|syminusp| (CAR |u|)) (MAKESTRING "-")) + ('T (MAKESTRING "+")))) + (SPADLET |dp| (|member| (|keyp| (|absym| (CAR |u|))) '(+ -))) + (SPADLET |tempx| + (PLUS (PLUS |x| (WIDTH |ac|)) (COND (|dp| 5) ('T 3)))) + (SPADLET |tempdblock| + (PROGN + (SPADLET |temparg1| + (APP |sc| (PLUS |x| 1) |y| |d|)) + (COND + (|dp| (SPADLET |bot| + (SPADDIFFERENCE |y| + (|subspan| |ac|))) + (SPADLET |top| + (PLUS |y| (|superspan| |ac|))) + (SPADLET |temparg2| + (|applpar| (PLUS |x| 3) |y| |bot| + |top| |temparg1|)) + (SPADLET |temparg3| + (APP |ac| (PLUS |x| 4) |y| + |temparg2|)) + (|apprpar| (PLUS (PLUS |x| 4) (WIDTH |ac|)) + |y| |bot| |top| |temparg3|)) + ('T (APP |ac| (PLUS |x| 3) |y| |temparg1|))))) + (|appsum| (CDR |u|) |tempx| |y| |tempdblock|)))))) + +;appneg(u, x, y, d) == +; appsum(LIST u, x - 1, y, d) + +(DEFUN |appneg| (|u| |x| |y| |d|) + (|appsum| (LIST |u|) (SPADDIFFERENCE |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) + +(DEFUN |appparu| (|u| |x| |y| |d|) + (PROG (|bot| |top| |temparg1| |temparg2|) + (RETURN + (PROGN + (SPADLET |bot| (SPADDIFFERENCE |y| (|subspan| |u|))) + (SPADLET |top| (PLUS |y| (|superspan| |u|))) + (SPADLET |temparg1| (|applpar| |x| |y| |bot| |top| |d|)) + (SPADLET |temparg2| (APP |u| (PLUS |x| 1) |y| |temparg1|)) + (|apprpar| (PLUS (PLUS |x| 1) (WIDTH |u|)) |y| |bot| |top| + |temparg2|))))) + +;appparu1(u, x, y, d) == +; appparu(CADR u, x, y, d) + +(DEFUN |appparu1| (|u| |x| |y| |d|) + (|appparu| (CADR |u|) |x| |y| |d|)) + +;appsc(u, x, y, d) == +; appagg1(rest u, x, y, d, '";") + +(DEFUN |appsc| (|u| |x| |y| |d|) + (|appagg1| (CDR |u|) |x| |y| |d| (MAKESTRING ";"))) + +;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) + +(DEFUN |appsetq| (|u| |x| |y| |d|) + (PROG (|w| |temparg1| |temparg2|) + (RETURN + (PROGN + (SPADLET |w| (WIDTH (CAR |u|))) + (SPADLET |temparg1| (APP (CADR |u|) |x| |y| |d|)) + (SPADLET |temparg2| + (APP (MAKESTRING ":") (PLUS |x| |w|) |y| |temparg1|)) + (APP (CADR (CDR |u|)) (PLUS (PLUS |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) + +(DEFUN |appsub| (|u| |x| |y| |d|) + (PROG (|temparg1| |temparg2| |temparg3|) + (RETURN + (PROGN + (SPADLET |temparg1| (PLUS |x| (WIDTH (CADR |u|)))) + (SPADLET |temparg2| + (SPADDIFFERENCE (SPADDIFFERENCE |y| 1) + (|superspan| (CDDR |u|)))) + (SPADLET |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))) + +(DEFUN |starstarcond| (|l| |iforwhen|) + (PROG (|a|) + (RETURN + (COND + ((NULL |l|) |l|) + ((EQ (SPADLET |a| (CAAR |l|)) 1) + (LIST 'CONCAT (CADR (CAR |l|)) (MAKESTRING " OTHERWISE"))) + ((EQCAR |a| 'COMPARG) + (|starstarcond| (CONS (|transcomparg| (CADR |a|)) (CDR |l|)) + |iforwhen|)) + ((NULL (CDR |l|)) + (LIST 'CONCAT (CADR (CAR |l|)) + (LIST 'CONCAT |iforwhen| (CAAR |l|)))) + ('T + (LIST 'VCONCAT + (|starstarcond| (CONS (CAR |l|) NIL) |iforwhen|) + (LIST 'VCONCAT (MAKESTRING " ") + (|starstarcond| (CDR |l|) |iforwhen|)))))))) + +;eq0(u) == 0 + +(DEFUN |eq0| (|u|) 0) + +;height(u) == +; superspan(u) + 1 + subspan(u) + +(DEFUN |height| (|u|) + (PLUS (PLUS (|superspan| |u|) 1) (|subspan| |u|))) + +;extsub(u) == +; MAX(subspan agg(5, u), height(agg(3, u)), subspan CADR u ) + +(DEFUN |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) ) + +(DEFUN |extsuper| (|u|) + (MAX (PLUS (|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) + +(DEFUN |extwidth| (|u|) + (PROG (|z| |n|) + (RETURN + (SEQ (PROGN + (SPADLET |n| + (MAX (WIDTH (CADR |u|)) (WIDTH (|agg| 4 |u|)) + (PLUS (PLUS 1 (WIDTH (|agg| 2 |u|))) + (WIDTH (|agg| 3 |u|))))) + (SEQ (OR NIL + (COND + ((AND (EQCAR (CAR (SPADLET |z| (|agg| 5 |u|))) + 'EXT) + (OR (EQ |n| 3) + (AND (> |n| 3) (NULL (ATOM |z|))))) + (EXIT (SPADLET |n| (PLUS 1 |n|)))))) + (PLUS |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) + +(DEFUN |appfrac| (|u| |x| |y| |d|) + (PROG (|w| |tempx| |tempy| |temparg3| |temparg4|) + (RETURN + (PROGN + (SPADLET |w| (WIDTH |u|)) + (SPADLET |tempx| + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE (PLUS 1 |w|) + (WIDTH (CADR (CDR |u|)))) + 2))) + (SPADLET |tempy| + (SPADDIFFERENCE + (SPADDIFFERENCE |y| + (|superspan| (CADR (CDR |u|)))) + 1)) + (SPADLET |temparg3| (APP (CADR (CDR |u|)) |tempx| |tempy| |d|)) + (SPADLET |temparg4| + (|apphor| |x| (SPADDIFFERENCE (PLUS |x| |w|) 1) |y| + |temparg3| (|specialChar| '|hbar|))) + (APP (CADR |u|) + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE (PLUS 1 |w|) (WIDTH (CADR |u|))) + 2)) + (PLUS (PLUS |y| 1) (|subspan| (CADR |u|))) |temparg4|))))) + +;fracsub(u) == height CADR rest u + +(DEFUN |fracsub| (|u|) + (|height| (CADR (CDR |u|)))) + +;fracsuper(u) == height CADR u + +(DEFUN |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) + +(DEFUN |fracwidth| (|u|) + (PROG (|num| |den| |numw| |ISTMP#1| |op| |denw|) + (RETURN + (PROGN + (SPADLET |numw| (WIDTH (SPADLET |num| (CADR |u|)))) + (SPADLET |denw| (WIDTH (SPADLET |den| (CADDR |u|)))) + (COND + ((AND (PAIRP |num|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |num|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T))) + (BOOT-EQUAL |op| 'OVER)) + (SPADLET |numw| (PLUS |numw| 2)))) + (COND + ((AND (PAIRP |den|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |den|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T))) + (BOOT-EQUAL |op| 'OVER)) + (SPADLET |denw| (PLUS |denw| 2)))) + (MAX |numw| |denw|))))) + +;slashSub u == +; MAX(1,subspan(CADR u),subspan(CADR rest u)) + +(DEFUN |slashSub| (|u|) + (MAX 1 (|subspan| (CADR |u|)) (|subspan| (CADR (CDR |u|))))) + +;slashSuper u == +; MAX(1,superspan(CADR u),superspan(CADR rest u)) + +(DEFUN |slashSuper| (|u|) + (MAX 1 (|superspan| (CADR |u|)) (|superspan| (CADR (CDR |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) + +(DEFUN |slashApp| (|u| |x| |y| |d|) + (PROG (|temparg1| |temparg2|) + (RETURN + (PROGN + (SPADLET |temparg1| (APP (CADR |u|) |x| |y| |d|)) + (SPADLET |temparg2| + (APP (MAKESTRING "/") (PLUS |x| (WIDTH (CADR |u|))) + |y| |temparg1|)) + (APP (CADR (CDR |u|)) (PLUS (PLUS |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 + +(DEFUN |slashWidth| (|u|) + (PLUS (PLUS 1 (WIDTH (CADR |u|))) (WIDTH (CADR (CDR |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) +; '" " + +(DEFUN |longext| (|u| |i| |n|) + (PROG (|x| |y|) + (RETURN + (PROGN + (SPADLET |x| (REVERSE |u|)) + (SPADLET |y| (CAR |x|)) + (SPADLET |u| + (|remWidth| + (REVERSEWOC (CONS (MAKESTRING " ") (CDR |x|))))) + (|charybdis| |u| |i| |n|) + (COND + ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) + (|charybdis| (CONS 'ELSE (LIST |y|)) |i| |n|) + (MAKESTRING " "))))) + +;appvertline(char, x, yl, yu, d) == +; yu < yl => d +; temparg := appvertline(char, x, yl, yu - 1, d) +; true => APP(char, x, yu, temparg) + +(DEFUN |appvertline| (|char| |x| |yl| |yu| |d|) + (PROG (|temparg|) + (RETURN + (COND + ((> |yl| |yu|) |d|) + ('T + (SPADLET |temparg| + (|appvertline| |char| |x| |yl| + (SPADDIFFERENCE |yu| 1) |d|)) + (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) + +(DEFUN |appHorizLine| (|xl| |xu| |y| |d|) + (PROG (|temparg|) + (RETURN + (COND + ((> |xl| |xu|) |d|) + ('T + (SPADLET |temparg| + (|appHorizLine| |xl| (SPADDIFFERENCE |xu| 1) |y| |d|)) + (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) + +(DEFUN |rootApp| (|u| |x| |y| |d|) + (PROG (|widB| |supB| |subB| |subR| |widR|) + (RETURN + (PROGN + (SPADLET |widB| (WIDTH (ELT |u| 1))) + (SPADLET |supB| (|superspan| (ELT |u| 1))) + (SPADLET |subB| (|subspan| (ELT |u| 1))) + (COND + ((> (|#| |u|) 2) (SPADLET |widR| (WIDTH (ELT |u| 2))) + (SPADLET |subR| (|subspan| (ELT |u| 2))) + (SPADLET |d| + (APP (ELT |u| 2) |x| + (PLUS (PLUS (SPADDIFFERENCE |y| |subB|) 1) + |subR|) + |d|))) + ('T (SPADLET |widR| 1))) + (SPADLET |d| + (APP (ELT |u| 1) (PLUS (PLUS |x| |widR|) 1) |y| |d|)) + (SPADLET |d| + (|apphor| (PLUS (PLUS |x| |widR|) 1) + (PLUS (PLUS |x| |widR|) |widB|) + (PLUS (PLUS |y| |supB|) 1) |d| + (|specialChar| '|hbar|))) + (SPADLET |d| + (|appvertline| (|specialChar| '|vbar|) + (PLUS |x| |widR|) (SPADDIFFERENCE |y| |subB|) + (PLUS |y| |supB|) |d|)) + (SPADLET |d| + (APP (|specialChar| '|ulc|) (PLUS |x| |widR|) + (PLUS (PLUS |y| |supB|) 1) |d|)) + (SPADLET |d| + (APP (|specialChar| '|urc|) + (PLUS (PLUS (PLUS |x| |widR|) |widB|) 1) + (PLUS (PLUS |y| |supB|) 1) |d|)) + (SPADLET |d| + (APP (|specialChar| '|bslash|) + (SPADDIFFERENCE (PLUS |x| |widR|) 1) + (SPADDIFFERENCE |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) + +(DEFUN |boxApp| (|u| |x| |y| |d|) + (PROG (|a| |b| |w|) + (RETURN + (COND + ((CDDR |u|) (|boxLApp| |u| |x| |y| |d|)) + ('T (SPADLET |a| (PLUS 1 (|superspan| (ELT |u| 1)))) + (SPADLET |b| (PLUS 1 (|subspan| (ELT |u| 1)))) + (SPADLET |w| (PLUS 2 (WIDTH (ELT |u| 1)))) + (SPADLET |d| + (|appvertline| (|specialChar| '|vbar|) |x| + (PLUS (SPADDIFFERENCE |y| |b|) 1) + (SPADDIFFERENCE (PLUS |y| |a|) 1) |d|)) + (SPADLET |d| + (|appvertline| (|specialChar| '|vbar|) + (PLUS (PLUS |x| |w|) 1) (SPADDIFFERENCE |y| |b|) + (PLUS |y| |a|) |d|)) + (SPADLET |d| + (|apphor| (PLUS |x| 1) (PLUS |x| |w|) + (SPADDIFFERENCE |y| |b|) |d| + (|specialChar| '|hbar|))) + (SPADLET |d| + (|apphor| (PLUS |x| 1) (PLUS |x| |w|) (PLUS |y| |a|) + |d| (|specialChar| '|hbar|))) + (SPADLET |d| + (APP (|specialChar| '|ulc|) |x| (PLUS |y| |a|) |d|)) + (SPADLET |d| + (APP (|specialChar| '|urc|) (PLUS (PLUS |x| |w|) 1) + (PLUS |y| |a|) |d|)) + (SPADLET |d| + (APP (|specialChar| '|llc|) |x| + (SPADDIFFERENCE |y| |b|) |d|)) + (SPADLET |d| + (APP (|specialChar| '|lrc|) (PLUS (PLUS |x| |w|) 1) + (SPADDIFFERENCE |y| |b|) |d|)) + (SPADLET |d| (APP (ELT |u| 1) (PLUS 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) + +(DEFUN |boxLApp| (|u| |x| |y| |d|) + (PROG (|la| |lb| |lw| |lh| |a| |b| |w| |top|) + (RETURN + (PROGN + (SPADLET |la| (|superspan| (ELT |u| 2))) + (SPADLET |lb| (|subspan| (ELT |u| 2))) + (SPADLET |lw| (PLUS 2 (WIDTH (ELT |u| 2)))) + (SPADLET |lh| (PLUS (PLUS 2 |la|) |lb|)) + (SPADLET |a| (PLUS (|superspan| (ELT |u| 1)) 1)) + (SPADLET |b| (PLUS (|subspan| (ELT |u| 1)) 1)) + (SPADLET |w| (MAX |lw| (PLUS 2 (WIDTH (ELT |u| 1))))) + (SPADLET |top| (PLUS (PLUS |y| |a|) |lh|)) + (SPADLET |d| + (|appvertline| MATBORCH |x| (SPADDIFFERENCE |y| |b|) + |top| |d|)) + (SPADLET |d| + (|appHorizLine| (PLUS |x| 1) (PLUS |x| |w|) |top| |d|)) + (SPADLET |d| + (APP (ELT |u| 2) (PLUS 2 |x|) + (PLUS (PLUS (PLUS |y| |a|) |lb|) 1) |d|)) + (SPADLET |d| + (|appHorizLine| (PLUS |x| 1) (PLUS |x| |lw|) + (PLUS |y| |a|) |d|)) + (COND + ((OR NIL (> |w| |lw|)) + (SPADLET |d| + (|appvertline| MATBORCH (PLUS (PLUS |x| |lw|) 1) + (PLUS |y| |a|) (SPADDIFFERENCE |top| 1) |d|))) + ('T (SPADLET |d| (APP (ELT |u| 1) (PLUS 2 |x|) |y| |d|)) + (SPADLET |d| + (|appHorizLine| (PLUS |x| 1) (PLUS |x| |w|) + (SPADDIFFERENCE |y| |b|) |top| |d|)) + (SPADLET |d| + (|appvertline| MATBORCH (PLUS (PLUS |x| |w|) 1) + (SPADDIFFERENCE |y| |b|) |top| |d|)))))))) + +;boxSub(x) == +; subspan x.1+1 + +(DEFUN |boxSub| (|x|) + (PLUS (|subspan| (ELT |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 + +(DEFUN |boxSuper| (|x|) + (PROG (|hl|) + (RETURN + (COND + ((NULL (CDR |x|)) 0) + ('T + (SPADLET |hl| + (COND + ((NULL (CDDR |x|)) 0) + ('T + (PLUS (PLUS 2 (|subspan| (ELT |x| 2))) + (|superspan| (ELT |x| 2)))))) + (PLUS (PLUS |hl| 1) (|superspan| (ELT |x| 1)))))))) + +;boxWidth(x) == +; null CDR x => 0 +; wl := +; null CDDR x => 0 +; true => WIDTH x.2 +; true => 4 + MAX(wl, WIDTH x.1) + +(DEFUN |boxWidth| (|x|) + (PROG (|wl|) + (RETURN + (COND + ((NULL (CDR |x|)) 0) + ('T + (SPADLET |wl| + (COND + ((NULL (CDDR |x|)) 0) + ('T (WIDTH (ELT |x| 2))))) + (PLUS 4 (MAX |wl| (WIDTH (ELT |x| 1))))))))) + +;nothingWidth x == +; 0 + +(DEFUN |nothingWidth| (|x|) 0) + +;nothingSuper x == +; 0 + +(DEFUN |nothingSuper| (|x|) 0) + +;nothingSub x == +; 0 + +(DEFUN |nothingSub| (|x|) 0) + +;nothingApp(u, x, y, d) == +; d + +(DEFUN |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) + +(DEFUN |zagApp| (|u| |x| |y| |d|) + (PROG (|w| |denx| |deny| |numx| |numy| |a| |b|) + (RETURN + (PROGN + (SPADLET |w| (WIDTH |u|)) + (SPADLET |denx| + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE |w| + (WIDTH (CADR (CDR |u|)))) + 2))) + (SPADLET |deny| + (SPADDIFFERENCE + (SPADDIFFERENCE |y| + (|superspan| (CADR (CDR |u|)))) + 1)) + (SPADLET |d| (APP (CADR (CDR |u|)) |denx| |deny| |d|)) + (SPADLET |numx| + (PLUS |x| + (QUOTIENT + (SPADDIFFERENCE |w| (WIDTH (CADR |u|))) 2))) + (SPADLET |numy| (PLUS (PLUS |y| 1) (|subspan| (CADR |u|)))) + (SPADLET |d| (APP (CADR |u|) |numx| |numy| |d|)) + (SPADLET |a| (PLUS 1 (|zagSuper| |u|))) + (SPADLET |b| (PLUS 1 (|zagSub| |u|))) + (SPADLET |d| + (|appvertline| (|specialChar| '|vbar|) |x| + (SPADDIFFERENCE |y| |b|) (SPADDIFFERENCE |y| 1) + |d|)) + (SPADLET |d| + (|appvertline| (|specialChar| '|vbar|) + (SPADDIFFERENCE (PLUS |x| |w|) 1) (PLUS |y| 1) + (PLUS |y| |a|) |d|)) + (SPADLET |d| + (|apphor| |x| (SPADDIFFERENCE (PLUS |x| |w|) 2) |y| + |d| (|specialChar| '|hbar|))) + (SPADLET |d| (APP (|specialChar| '|ulc|) |x| |y| |d|)) + (SPADLET |d| + (APP (|specialChar| '|lrc|) + (SPADDIFFERENCE (PLUS |x| |w|) 1) |y| |d|)))))) + +;zagSub(u) == +; height CADR rest u + +(DEFUN |zagSub| (|u|) + (|height| (CADR (CDR |u|)))) + +;zagSuper(u) == +; height CADR u + +(DEFUN |zagSuper| (|u|) + (|height| (CADR |u|))) + +;zagWidth(x) == +; #x = 1 => 0 +; #x = 2 => 4 + WIDTH x.1 +; 4 + MAX(WIDTH x.1, WIDTH x.2) + +(DEFUN |zagWidth| (|x|) + (COND + ((EQL (|#| |x|) 1) 0) + ((EQL (|#| |x|) 2) (PLUS 4 (WIDTH (ELT |x| 1)))) + ('T (PLUS 4 (MAX (WIDTH (ELT |x| 1)) (WIDTH (ELT |x| 2))))))) + +;rootWidth(x) == +; #x <= 2 => 3 + WIDTH x.1 +; 2 + WIDTH x.1 + WIDTH x.2 + +(DEFUN |rootWidth| (|x|) + (COND + ((<= (|#| |x|) 2) (PLUS 3 (WIDTH (ELT |x| 1)))) + ('T (PLUS (PLUS 2 (WIDTH (ELT |x| 1))) (WIDTH (ELT |x| 2)))))) + +;rootSub(x) == +; subspan x.1 + +(DEFUN |rootSub| (|x|) + (|subspan| (ELT |x| 1))) + +;rootSuper(x) == +; normal := 1 + superspan x.1 +; #x <= 2 => normal +; (radOver := height x.2 - height x.1) < 0 => normal +; normal + radOver + +(DEFUN |rootSuper| (|x|) + (PROG (|normal| |radOver|) + (RETURN + (PROGN + (SPADLET |normal| (PLUS 1 (|superspan| (ELT |x| 1)))) + (COND + ((<= (|#| |x|) 2) |normal|) + ((MINUSP (SPADLET |radOver| + (SPADDIFFERENCE (|height| (ELT |x| 2)) + (|height| (ELT |x| 1))))) + |normal|) + ('T (PLUS |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 + +(DEFUN |appmat| (|u| |x| |y| |d|) + (PROG (|p| |q| |wl| |yc| |subl| |superl| |rows| |flag| |xc| |row| + |w|) + (RETURN + (SEQ (PROGN + (SPADLET |rows| (CDDR |u|)) + (SPADLET |p| (|matSuper| |u|)) + (SPADLET |q| (|matSub| |u|)) + (SPADLET |d| + (|matrixBorder| |x| (SPADDIFFERENCE |y| |q|) + (PLUS |y| |p|) |d| '|left|)) + (SPADLET |x| (PLUS 1 |x|)) + (SPADLET |yc| (PLUS (PLUS 1 |y|) |p|)) + (SPADLET |w| (CADR |u|)) + (SPADLET |wl| (CDAR |w|)) + (SPADLET |subl| (CDR (CADR |w|))) + (SPADLET |superl| (CDR (CADR (CDR |w|)))) + (DO () (NIL NIL) + (SEQ (EXIT (COND + ((NULL |rows|) + (RETURN + (|matrixBorder| + (SPADDIFFERENCE + (PLUS |x| (WIDTH |u|)) 2) + (SPADDIFFERENCE |y| |q|) + (PLUS |y| |p|) |d| '|right|))) + ('T (SPADLET |xc| |x|) + (SPADLET |yc| + (SPADDIFFERENCE + (SPADDIFFERENCE |yc| 1) + (CAR |superl|))) + (SPADLET |w| |wl|) + (SPADLET |row| (CDAR |rows|)) + (DO () (NIL NIL) + (SEQ (EXIT + (PROGN + (COND + ((BOOT-EQUAL |flag| + (MAKESTRING "ON")) + (SPADLET |flag| + (MAKESTRING "OFF")) + (RETURN NIL))) + (COND + ((NULL |row|) + (DO () (NIL NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |yc| + (SPADDIFFERENCE + (SPADDIFFERENCE |yc| + 1) + (CAR |subl|))) + (SPADLET |subl| + (CDR |subl|)) + (SPADLET |superl| + (CDR |superl|)) + (SPADLET |rows| + (CDR |rows|)) + (RETURN + (PROGN + (SPADLET |flag| + (MAKESTRING "ON")) + NIL))))))) + ('T + (SPADLET |d| + (APP (CAR |row|) + (PLUS |xc| + (QUOTIENT + (SPADDIFFERENCE (CAR |w|) + (WIDTH (CAR |row|))) + 2)) + |yc| |d|)) + (SPADLET |xc| + (PLUS (PLUS |xc| 2) + (CAR |w|))) + (SPADLET |row| (CDR |row|)) + (SPADLET |w| + (CDR |w|)))))))))))))))))) + +;matSuper(x) == +; (x := x.1) => -1 + QUOTIENT(first x.1 + first x.2, 2) +; true => ERROR('MAT) + +(DEFUN |matSuper| (|x|) + (COND + ((SPADLET |x| (ELT |x| 1)) + (PLUS (SPADDIFFERENCE 1) + (QUOTIENT (PLUS (CAR (ELT |x| 1)) (CAR (ELT |x| 2))) 2))) + ('T (ERROR 'MAT)))) + +;matSub(x) == +; (x := x.1) => QUOTIENT(-1 + first x.1 + first x.2, 2) +; true => ERROR('MAT) + +(DEFUN |matSub| (|x|) + (COND + ((SPADLET |x| (ELT |x| 1)) + (QUOTIENT + (PLUS (PLUS (SPADDIFFERENCE 1) (CAR (ELT |x| 1))) + (CAR (ELT |x| 2))) + 2)) + ('T (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 + +(DEFUN |matWidth| (|x|) + (PROG (|y| |numOfColumns| |widthList| |subspanList| |superspanList|) + (RETURN + (PROGN + (SPADLET |y| (CDDR |x|)) + (SPADLET |numOfColumns| (LENGTH (CDAR |y|))) + (SPADLET |widthList| + (|matLSum2| (|matWList| |y| (NLIST |numOfColumns| 0)))) + (SPADLET |subspanList| (|matLSum| (|matSubList| |y|))) + (SPADLET |superspanList| (|matLSum| (|matSuperList| |y|))) + (RPLAC (ELT |x| 1) + (CONS |widthList| + (CONS |subspanList| (CONS |superspanList| NIL)))) + (CAAR (ELT |x| 1)))))) + +;matLSum(x) == +; CONS(sumoverlist x + LENGTH x, x) + +(DEFUN |matLSum| (|x|) + (CONS (PLUS (|sumoverlist| |x|) (LENGTH |x|)) |x|)) + +;matLSum2(x) == +; CONS(sumoverlist x + 2*(LENGTH x), x) + +(DEFUN |matLSum2| (|x|) + (CONS (PLUS (|sumoverlist| |x|) (TIMES 2 (LENGTH |x|))) |x|)) + +;matWList(x, y) == +; null x => y +; true => matWList(rest x, matWList1(CDAR x, y) ) + +(DEFUN |matWList| (|x| |y|) + (COND + ((NULL |x|) |y|) + ((QUOTE T) (|matWList| (CDR |x|) (|matWList1| (CDAR |x|) |y|))))) + +;matWList1(x, y) == +; null x => nil +; true => CONS(MAX(WIDTH first x, first y), matWList1(rest x, rest y) ) + +(DEFUN |matWList1| (|x| |y|) + (COND + ((NULL |x|) NIL) + ('T + (CONS (MAX (WIDTH (CAR |x|)) (CAR |y|)) + (|matWList1| (CDR |x|) (CDR |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) ) + +(DEFUN |matSubList| (|x|) + (COND + ((NULL |x|) NIL) + ('T (CONS (|matSubList1| (CDAR |x|) 0) (|matSubList| (CDR |x|)))))) + +;matSubList1(x, y) == +; null x => y +; true => matSubList1(rest x, MAX(y, subspan first x) ) + +(DEFUN |matSubList1| (|x| |y|) + (COND + ((NULL |x|) |y|) + ('T (|matSubList1| (CDR |x|) (MAX |y| (|subspan| (CAR |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) ) + +(DEFUN |matSuperList| (|x|) + (COND + ((NULL |x|) NIL) + ('T + (CONS (|matSuperList1| (CDAR |x|) 0) (|matSuperList| (CDR |x|)))))) + +;matSuperList1(x, y) == +; null x => y +; true => matSuperList1(rest x, MAX(y, superspan first x) ) + +(DEFUN |matSuperList1| (|x| |y|) + (COND + ((NULL |x|) |y|) + ('T (|matSuperList1| (CDR |x|) (MAX |y| (|superspan| (CAR |x|))))))) + +;minusWidth(u) == +; -1 + sumWidthA rest u + +(DEFUN |minusWidth| (|u|) + (PLUS (SPADDIFFERENCE 1) (|sumWidthA| (CDR |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) + +(DEFUN |bracketagglist| + (|u| |start| |linelength| |tchr| |open| |close|) + (PROG (|lastx| |s| |nextu| |x| |ichr|) + (RETURN + (SEQ (PROGN + (SPADLET |u| + (CONS (LIST 'CONCAT |open| (CAR |u|)) + (PROG (G169906) + (SPADLET G169906 NIL) + (RETURN + (DO ((G169911 (CDR |u|) + (CDR G169911)) + (|y| NIL)) + ((OR (ATOM G169911) + (PROGN + (SETQ |y| (CAR G169911)) + NIL)) + (NREVERSE0 G169906)) + (SEQ (EXIT + (SETQ G169906 + (CONS + (LIST 'CONCAT + (MAKESTRING " ") |y|) + G169906))))))))) + (DO () (NIL NIL) + (SEQ (EXIT (PROGN + (SPADLET |s| 0) + (DO ((|x| |u| (CDR |x|))) ((ATOM |x|) NIL) + (SEQ (EXIT + (PROGN + (SPADLET |lastx| |x|) + (COND + ((>= + (SPADLET |s| + (PLUS + (PLUS |s| + (WIDTH (CAR |x|))) + 1)) + |linelength|) + (RETURN |s|)) + ((NULL (CDR |x|)) + (RETURN + (SPADLET |s| + (SPADDIFFERENCE 1))))))))) + (OR NIL + (COND + ((EQ |s| (SPADDIFFERENCE 1)) + (SPADLET |nextu| NIL)) + ((EQ |lastx| |u|) + (SPADLET |nextu| (CDR |u|)) + (RPLACD |u| NIL)) + ('T (SPADLET |nextu| |lastx|) + (RPLACD (PREDECESSOR |lastx| |u|) + NIL)))) + (DO ((|x| |u| (CDR |x|))) ((ATOM |x|) NIL) + (SEQ (EXIT + (RPLACA |x| + (LIST 'CONCAT (CAR |x|) |tchr|))))) + (COND + ((NULL |nextu|) + (RPLACA (CDDR (|last| |u|)) |close|))) + (SPADLET |x| + (ASSOCIATER 'CONCAT + (CONS |ichr| |u|))) + (|charybdis| (ASSOCIATER 'CONCAT |u|) + |start| |linelength|) + (COND + (|$collectOutput| + (TERPRI |$algebraOutputStream|))) + (SPADLET |ichr| (MAKESTRING " ")) + (SPADLET |u| |nextu|) + (COND ((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 + +(DEFUN |prnd| (|start| |op|) + (PROG (|string|) + (RETURN + (COND + (|$testOutputLineFlag| + (SPADLET |string| + (STRCONC (|fillerSpaces| + (MAX 0 (SPADDIFFERENCE |start| 1))) + |op|)) + (SPADLET |$testOutputLineList| + (CONS |string| |$testOutputLineList|))) + ('T + (PRINTEXP (|fillerSpaces| (MAX 0 (SPADDIFFERENCE |start| 1))) + |$algebraOutputStream|) + (COND + (|$collectOutput| + (SPADLET |string| + (STRCONC (|fillerSpaces| + (MAX 0 (SPADDIFFERENCE |start| 1))) + |op|)) + (SPADLET |$outputLines| (CONS |string| |$outputLines|))) + ('T (PRINTEXP |op| |$algebraOutputStream|) + (TERPRI |$algebraOutputStream|)))))))) + +;qTSub(u) == +; subspan CADR u + +(DEFUN |qTSub| (|u|) (|subspan| (CADR |u|))) + +;qTSuper(u) == +; superspan CADR u + +(DEFUN |qTSuper| (|u|) (|superspan| (CADR |u|))) + +;qTWidth(u) == +; 2 + WIDTH CADR u + +(DEFUN |qTWidth| (|u|) (PLUS 2 (WIDTH (CADR |u|)))) + +;remWidth(x) == +; atom x => x +; true => CONS( (atom first x => first x; true => CAAR x), +; MMAPCAR(remWidth, rest x) ) + +(DEFUN |remWidth| (|x|) + (COND + ((ATOM |x|) |x|) + ('T + (CONS (COND ((ATOM (CAR |x|)) (CAR |x|)) ('T (CAAR |x|))) + (MMAPCAR |remWidth| (CDR |x|)))))) + +;subSub(u) == +; height CDDR u + +(DEFUN |subSub| (|u|) (|height| (CDDR |u|))) + +;subSuper u == +; superspan u.1 + +(DEFUN |subSuper| (|u|) (|superspan| (ELT |u| 1))) + +;letWidth u == +; 5 + WIDTH u.1 + WIDTH u.2 + +(DEFUN |letWidth| (|u|) + (PLUS (PLUS 5 (WIDTH (ELT |u| 1))) (WIDTH (ELT |u| 2)))) + +;sumoverlist(u) == +/[x for x in u] + +(DEFUN |sumoverlist| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G169996) + (SPADLET G169996 0) + (RETURN + (DO ((G170001 |u| (CDR G170001)) (|x| NIL)) + ((OR (ATOM G170001) + (PROGN (SETQ |x| (CAR G170001)) NIL)) + G169996) + (SEQ (EXIT (SETQ G169996 (PLUS G169996 |x|))))))))))) + +;sumWidth u == +; WIDTH u.1 + sumWidthA CDDR u + +(DEFUN |sumWidth| (|u|) + (PLUS (WIDTH (ELT |u| 1)) (|sumWidthA| (CDDR |u|)))) + +;sumWidthA u == +; ^u => 0 +; ( MEMBER(keyp absym first u,'(_+ _-)) => 5; true => 3) + +; WIDTH absym first u + +; sumWidthA rest u + +(DEFUN |sumWidthA| (|u|) + (COND + ((NULL |u|) 0) + ('T + (PLUS (PLUS (COND + ((|member| (|keyp| (|absym| (CAR |u|))) '(+ -)) 5) + ('T 3)) + (WIDTH (|absym| (CAR |u|)))) + (|sumWidthA| (CDR |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 + +(DEFUN |superSubApp| (|u| |x| |y| |di|) + (PROG (|a| |b| |c| |d| |e| |wd| |we| |aox| |ar| |ab| |aw|) + (RETURN + (PROGN + (SPADLET |a| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |b| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |c| + (OR (CAR (SPADLET |u| (KDR |u|))) '((NOTHING . 0)))) + (SPADLET |d| + (OR (KAR (SPADLET |u| (KDR |u|))) '((NOTHING . 0)))) + (SPADLET |e| (OR (KADR |u|) '((NOTHING . 0)))) + (SPADLET |aox| + (MAX (SPADLET |wd| (WIDTH |d|)) + (SPADLET |we| (WIDTH |e|)))) + (SPADLET |ar| (|superspan| |a|)) + (SPADLET |ab| (|subspan| |a|)) + (SPADLET |aw| (WIDTH |a|)) + (SPADLET |di| + (APP |d| (PLUS |x| (SPADDIFFERENCE |aox| |wd|)) + (PLUS (PLUS (PLUS 1 |ar|) |y|) (|subspan| |d|)) + |di|)) + (SPADLET |di| (APP |a| (PLUS |x| |aox|) |y| |di|)) + (SPADLET |di| + (APP |c| (PLUS (PLUS |aox| |aw|) |x|) + (PLUS (PLUS (PLUS 1 |y|) |ar|) (|subspan| |c|)) + |di|)) + (SPADLET |di| + (APP |e| (PLUS |x| (SPADDIFFERENCE |aox| |we|)) + (SPADDIFFERENCE (SPADDIFFERENCE |y| 1) + (MAX (|superspan| |e|) |ab|)) + |di|)) + (SPADLET |di| + (APP |b| (PLUS (PLUS |aox| |aw|) |x|) + (SPADDIFFERENCE (SPADDIFFERENCE |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 + +(DEFUN |stringer| (|x|) + (PROG (|s|) + (RETURN + (COND + ((STRINGP |x|) |x|) + ((EQ '|\|| (FETCHCHAR (SPADLET |s| (STRINGIMAGE |x|)) 0)) + (RPLACSTR |s| 0 1 '|| NIL NIL)) + ('T |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) + +(DEFUN |superSubSub| (|u|) + (PROG (|a| |b| |e|) + (RETURN + (PROGN + (SPADLET |a| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |b| (KAR (SPADLET |u| (KDR |u|)))) + (SPADLET |e| (KAR (KDR (KDR (KDR |u|))))) + (RETURN + (PLUS (|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) + +(DEFUN |binomApp| (|u| |x| |y| |d|) + (PROG (|LETTMP#1| |num| |den| |ysub| |ysup| |wden| |wnum| |hnum| + |hden| |w|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (CDR |u|)) + (SPADLET |num| (CAR |LETTMP#1|)) + (SPADLET |den| (CADR |LETTMP#1|)) + (SPADLET |ysub| + (SPADDIFFERENCE (SPADDIFFERENCE |y| 1) + (|superspan| |den|))) + (SPADLET |ysup| (PLUS (PLUS |y| 1) (|subspan| |num|))) + (SPADLET |wden| (WIDTH |den|)) + (SPADLET |wnum| (WIDTH |num|)) + (SPADLET |w| (MAX |wden| |wnum|)) + (SPADLET |d| + (APP |den| + (PLUS (PLUS |x| 1) + (QUOTIENT (SPADDIFFERENCE |w| |wden|) + 2)) + |ysub| |d|)) + (SPADLET |d| + (APP |num| + (PLUS (PLUS |x| 1) + (QUOTIENT (SPADDIFFERENCE |w| |wnum|) + 2)) + |ysup| |d|)) + (SPADLET |hnum| (|height| |num|)) + (SPADLET |hden| (|height| |den|)) + (SPADLET |w| (PLUS 1 |w|)) + (DO ((G170072 (SPADDIFFERENCE |hnum| 1)) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G170072) NIL) + (SEQ (EXIT (PROGN + (SPADLET |d| + (|appChar| (|specialChar| '|vbar|) + |x| (PLUS |y| |j|) |d|)) + (SPADLET |d| + (|appChar| (|specialChar| '|vbar|) + (PLUS |x| |w|) (PLUS |y| |j|) + |d|)))))) + (DO ((G170081 (SPADDIFFERENCE |hden| 1)) + (|j| 1 (QSADD1 |j|))) + ((QSGREATERP |j| G170081) NIL) + (SEQ (EXIT (PROGN + (SPADLET |d| + (|appChar| (|specialChar| '|vbar|) + |x| (SPADDIFFERENCE |y| |j|) |d|)) + (SPADLET |d| + (|appChar| (|specialChar| '|vbar|) + (PLUS |x| |w|) + (SPADDIFFERENCE |y| |j|) |d|)))))) + (SPADLET |d| + (|appChar| (|specialChar| '|ulc|) |x| + (PLUS |y| |hnum|) |d|)) + (SPADLET |d| + (|appChar| (|specialChar| '|urc|) (PLUS |x| |w|) + (PLUS |y| |hnum|) |d|)) + (SPADLET |d| + (|appChar| (|specialChar| '|llc|) |x| + (SPADDIFFERENCE |y| |hden|) |d|)) + (SPADLET |d| + (|appChar| (|specialChar| '|lrc|) (PLUS |x| |w|) + (SPADDIFFERENCE |y| |hden|) |d|))))))) + +;binomSub u == height CADDR u + +(DEFUN |binomSub| (|u|) (|height| (CADDR |u|))) + +;binomSuper u == height CADR u + +(DEFUN |binomSuper| (|u|) (|height| (CADR |u|))) + +;binomWidth u == 2 + MAX(WIDTH CADR u, WIDTH CADDR u) + +(DEFUN |binomWidth| (|u|) + (PLUS 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 + +(DEFUN |altSuperSubApp| (|u| |x| |y| |di|) + (PROG (|a| |ar| |ab| |aw| |sublist| |suplist| |ysub| |ysup| |wsub| + |wsup|) + (RETURN + (SEQ (PROGN + (SPADLET |a| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |ar| (|superspan| |a|)) + (SPADLET |ab| (|subspan| |a|)) + (SPADLET |aw| (WIDTH |a|)) + (SPADLET |di| (APP |a| |x| |y| |di|)) + (SPADLET |x| (PLUS |x| |aw|)) + (SPADLET |sublist| (|everyNth| (SPADLET |u| (CDR |u|)) 2)) + (SPADLET |suplist| (|everyNth| (IFCDR |u|) 2)) + (SPADLET |ysub| + (SPADDIFFERENCE (SPADDIFFERENCE |y| 1) + (APPLY 'MAX + (CONS |ab| + (PROG (G170124) + (SPADLET G170124 NIL) + (RETURN + (DO + ((G170129 |sublist| + (CDR G170129)) + (|s| NIL)) + ((OR (ATOM G170129) + (PROGN + (SETQ |s| + (CAR G170129)) + NIL)) + (NREVERSE0 G170124)) + (SEQ + (EXIT + (SETQ G170124 + (CONS (|superspan| |s|) + G170124))))))))))) + (SPADLET |ysup| + (PLUS (PLUS |y| 1) + (APPLY 'MAX + (CONS |ar| + (PROG (G170139) + (SPADLET G170139 NIL) + (RETURN + (DO + ((G170144 |sublist| + (CDR G170144)) + (|s| NIL)) + ((OR (ATOM G170144) + (PROGN + (SETQ |s| (CAR G170144)) + NIL)) + (NREVERSE0 G170139)) + (SEQ + (EXIT + (SETQ G170139 + (CONS (|subspan| |s|) + G170139))))))))))) + (DO ((G170159 |sublist| (CDR G170159)) (|sub| NIL) + (G170160 |suplist| (CDR G170160)) (|sup| NIL)) + ((OR (ATOM G170159) + (PROGN (SETQ |sub| (CAR G170159)) NIL) + (ATOM G170160) + (PROGN (SETQ |sup| (CAR G170160)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |wsub| (WIDTH |sub|)) + (SPADLET |wsup| (WIDTH |sup|)) + (SPADLET |di| (APP |sub| |x| |ysub| |di|)) + (SPADLET |di| (APP |sup| |x| |ysup| |di|)) + (SPADLET |x| + (PLUS (PLUS |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] + +(DEFUN |everyNth| (|l| |n|) + (PROG (|e|) + (RETURN + (SEQ (PROG (G170199) + (SPADLET G170199 NIL) + (RETURN + (DO () ((NULL |l|) (NREVERSE0 G170199)) + (SEQ (EXIT (SETQ G170199 + (CONS (PROGN + (SPADLET |e| (ELT |l| 0)) + (DO ((|i| 1 (QSADD1 |i|))) + ((OR (QSGREATERP |i| |n|) + (NULL |l|)) + NIL) + (SEQ + (EXIT + (SPADLET |l| (CDR |l|))))) + |e|) + G170199))))))))))) + +;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 + +(DEFUN |altSuperSubSub| (|u|) + (PROG (|sublist| |h| |span|) + (RETURN + (SEQ (PROGN + (SPADLET |span| (|subspan| (CADR |u|))) + (SPADLET |sublist| (|everyNth| (CDDR |u|) 2)) + (DO ((G170231 |sublist| (CDR G170231)) (|sub| NIL)) + ((OR (ATOM G170231) + (PROGN (SETQ |sub| (CAR G170231)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |h| (|height| |sub|)) + (COND + ((> |h| |span|) (SPADLET |span| |h|)) + ('T NIL)))))) + |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 + +(DEFUN |altSuperSubSuper| (|u|) + (PROG (|suplist| |h| |span|) + (RETURN + (SEQ (PROGN + (SPADLET |span| (|superspan| (CADR |u|))) + (SPADLET |suplist| (|everyNth| (IFCDR (CDDR |u|)) 2)) + (DO ((G170251 |suplist| (CDR G170251)) (|sup| NIL)) + ((OR (ATOM G170251) + (PROGN (SETQ |sup| (CAR G170251)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |h| (|height| |sup|)) + (COND + ((> |h| |span|) (SPADLET |span| |h|)) + ('T NIL)))))) + |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 + +(DEFUN |altSuperSubWidth| (|u|) + (PROG (|suplist| |sublist| |wsup| |wsub| |w|) + (RETURN + (SEQ (PROGN + (SPADLET |w| (WIDTH (CADR |u|))) + (SPADLET |suplist| (|everyNth| (IFCDR (CDDR |u|)) 2)) + (SPADLET |sublist| (|everyNth| (CDDR |u|) 2)) + (DO ((G170273 |suplist| (CDR G170273)) (|sup| NIL) + (G170274 |sublist| (CDR G170274)) (|sub| NIL)) + ((OR (ATOM G170273) + (PROGN (SETQ |sup| (CAR G170273)) NIL) + (ATOM G170274) + (PROGN (SETQ |sub| (CAR G170274)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |wsup| (WIDTH |sup|)) + (SPADLET |wsub| (WIDTH |sub|)) + (SPADLET |w| + (PLUS (PLUS |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 + +(DEFUN |superSubWidth| (|u|) + (PROG (|a| |b| |c| |d| |e|) + (RETURN + (PROGN + (SPADLET |a| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |b| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |c| + (OR (CAR (SPADLET |u| (KDR |u|))) '((NOTHING . 0)))) + (SPADLET |d| + (OR (KAR (SPADLET |u| (KDR |u|))) '((NOTHING . 0)))) + (SPADLET |e| (OR (KADR |u|) '((NOTHING . 0)))) + (RETURN + (PLUS (PLUS (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) + +(DEFUN |superSubSuper| (|u|) + (PROG (|a| |c| |d|) + (RETURN + (PROGN + (SPADLET |a| (CAR (SPADLET |u| (CDR |u|)))) + (SPADLET |c| (KAR (SPADLET |u| (KDR (KDR |u|))))) + (SPADLET |d| (KADR |u|)) + (RETURN + (PLUS (|superspan| |a|) (MAX (|height| |c|) (|height| |d|)))))))) + +;suScWidth u == +; WIDTH u.1 + aggwidth CDDR u + +(DEFUN |suScWidth| (|u|) + (PLUS (WIDTH (ELT |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) + +(DEFUN |transcomparg| (|x|) + (PROG (|y| |args| |conds|) + (RETURN + (SEQ (PROGN + (SPADLET |y| (CAR |x|)) + (SPADLET |args| + (CAR (*NTH STANDARGLIST (PLUS 1 (LENGTH |y|))))) + (DO () (NIL NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL |y|) (RETURN NIL)) + ((AND (ATOM (CAR |y|)) + (|member| (CAR |y|) FRLIS*)) + (SPADLET |conds| + (CONS + (LIST 'EQUAL1 (CAR |args|) + (CAR |y|)) + |conds|)) + (SPADLET |y| + (MSUBST (CAR |args|) (CAR |y|) + |y|)) + (SPADLET |x| + (MSUBST (CAR |args|) (CAR |y|) + |x|))) + ((BOOT-EQUAL (CAR |y|) (CAR |args|)) NIL) + ('T + (SPADLET |conds| + (CONS + (LIST 'EQUAL1 (CAR |args|) + (CAR |y|)) + |conds|)))) + (SPADLET |y| (CDR |y|)) + (SPADLET |args| (CDR |args|)))))) + (SPADLET |conds| + (COND + ((NULL |conds|) (CDR (CADR |x|))) + ('T + (ANDSIMP (CONS 'AND + (APPEND (REVERSEWOC |conds|) + (LIST (CDR (CADR |x|))))))))) + (LIST (COND (|conds| |conds|) ('T 1)) (CADR (CDR |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 + +(DEFUN |vconcatapp| (|u| |x| |y| |d|) + (PROG (|w| |xoff|) + (RETURN + (SEQ (PROGN + (SPADLET |w| (|vConcatWidth| |u|)) + (SPADLET |y| + (PLUS (PLUS |y| (|superspan| (ELT |u| 1))) 1)) + (DO ((G170351 (CDR |u|) (CDR G170351)) (|a| NIL)) + ((OR (ATOM G170351) + (PROGN (SETQ |a| (CAR G170351)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |y| + (SPADDIFFERENCE + (SPADDIFFERENCE |y| + (|superspan| |a|)) + 1)) + (SPADLET |xoff| + (QUOTIENT + (SPADDIFFERENCE |w| (WIDTH |a|)) + 2)) + (SPADLET |d| + (APP |a| (PLUS |x| |xoff|) |y| + |d|)) + (SPADLET |y| + (SPADDIFFERENCE |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) + +(DEFUN |binomialApp| (|u| |x| |y| |d|) + (PROG (|b| |a| |w| |y1| |y2| |xoff|) + (RETURN + (PROGN + (SPADLET |b| (CADR |u|)) + (SPADLET |a| (CADDR |u|)) + (SPADLET |w| (|vConcatWidth| |u|)) + (SPADLET |d| (APP (MAKESTRING "(") |x| |y| |d|)) + (SPADLET |x| (PLUS |x| 1)) + (SPADLET |y1| (SPADDIFFERENCE |y| (|height| |a|))) + (SPADLET |xoff| (QUOTIENT (SPADDIFFERENCE |w| (WIDTH |a|)) 2)) + (SPADLET |d| (APP |a| (PLUS |x| |xoff|) |y1| |d|)) + (SPADLET |y2| (PLUS |y| (|height| |b|))) + (SPADLET |xoff| (QUOTIENT (SPADDIFFERENCE |w| (WIDTH |b|)) 2)) + (SPADLET |d| (APP |b| (PLUS |x| |xoff|) |y2| |d|)) + (SPADLET |x| (PLUS |x| |w|)) + (APP (MAKESTRING ")") |x| |y| |d|))))) + +;vConcatSub u == +; subspan u.1 + +/[height a for a in CDDR u] + +(DEFUN |vConcatSub| (|u|) + (PROG () + (RETURN + (SEQ (PLUS (|subspan| (ELT |u| 1)) + (PROG (G170385) + (SPADLET G170385 0) + (RETURN + (DO ((G170390 (CDDR |u|) (CDR G170390)) + (|a| NIL)) + ((OR (ATOM G170390) + (PROGN (SETQ |a| (CAR G170390)) NIL)) + G170385) + (SEQ (EXIT (SETQ G170385 + (PLUS G170385 (|height| |a|))))))))))))) + +;vConcatSuper u == +; superspan u.1 + +(DEFUN |vConcatSuper| (|u|) (|superspan| (ELT |u| 1))) + +;vConcatWidth u == +; w := 0 +; for a in rest u repeat if (wa := WIDTH a) > w then w := wa +; w + +(DEFUN |vConcatWidth| (|u|) + (PROG (|wa| |w|) + (RETURN + (SEQ (PROGN + (SPADLET |w| 0) + (DO ((G170407 (CDR |u|) (CDR G170407)) (|a| NIL)) + ((OR (ATOM G170407) + (PROGN (SETQ |a| (CAR G170407)) NIL)) + NIL) + (SEQ (EXIT (COND + ((> (SPADLET |wa| (WIDTH |a|)) |w|) + (SPADLET |w| |wa|)) + ('T NIL))))) + |w|))))) + +;binomialSub u == height u.2 + 1 + +(DEFUN |binomialSub| (|u|) (PLUS (|height| (ELT |u| 2)) 1)) + +;binomialSuper u == height u.1 + 1 + +(DEFUN |binomialSuper| (|u|) (PLUS (|height| (ELT |u| 1)) 1)) + +;binomialWidth u == 2 + MAX(WIDTH u.1, WIDTH u.2) + +(DEFUN |binomialWidth| (|u|) + (PLUS 2 (MAX (WIDTH (ELT |u| 1)) (WIDTH (ELT |u| 2))))) + +;mathPrint u == +; if ^$collectOutput then TERPRI $algebraOutputStream +; (u := STRINGP mathPrint1(mathPrintTran u, nil) => +; PSTRING u; nil) + +(DEFUN |mathPrint| (|u|) + (PROGN + (COND ((NULL |$collectOutput|) (TERPRI |$algebraOutputStream|))) + (COND + ((SPADLET |u| (STRINGP (|mathPrint1| (|mathPrintTran| |u|) NIL))) + (PSTRING |u|)) + ('T NIL)))) + +;mathPrintTran u == +; atom u => u +; true => +; for x in tails u repeat +; RPLAC(first x, mathPrintTran first x) +; u + +(DEFUN |mathPrintTran| (|u|) + (SEQ (COND + ((ATOM |u|) |u|) + ('T + (DO ((|x| |u| (CDR |x|))) ((ATOM |x|) NIL) + (SEQ (EXIT (RPLAC (CAR |x|) (|mathPrintTran| (CAR |x|)))))) + |u|)))) + +;mathPrint1(x,fg) == +; if fg and ^$collectOutput then TERPRI $algebraOutputStream +; maPrin x +; if fg and ^$collectOutput then TERPRI $algebraOutputStream + +(DEFUN |mathPrint1| (|x| |fg|) + (PROGN + (COND + ((AND |fg| (NULL |$collectOutput|)) + (TERPRI |$algebraOutputStream|))) + (|maPrin| |x|) + (COND + ((AND |fg| (NULL |$collectOutput|)) + (TERPRI |$algebraOutputStream|)) + ('T NIL)))) + +;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 + +(DEFUN |maPrin| (|u|) + (PROG (|c| |ISTMP#1| |ISTMP#2| |num| |ISTMP#3| |form|) + (RETURN + (COND + ((NULL |u|) NIL) + ('T + (COND + ((OR |$runTestFlag| |$mkTestFlag|) + (SPADLET |$mkTestOutputStack| + (CONS (COPY |u|) |$mkTestOutputStack|)))) + (SPADLET |$highlightDelta| 0) + (SPADLET |c| + (CATCH '|outputFailure| + (|charybdis| |u| $MARGIN $LINELENGTH))) + (COND + ((NEQUAL |c| '|outputFailure|) |c|) + ('T (|sayKeyedMsg| 'S2IX0009 NIL) + (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) 'EQUATNUM) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |num| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |form| + (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'EQUATNUM))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |u|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |num| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |form| + (QCAR |ISTMP#3|)) + 'T))))))) + (|charybdis| (CONS 'EQUATNUM (CONS |num| NIL)) $MARGIN + $LINELENGTH) + (COND + ((NULL |$collectOutput|) + (TERPRI |$algebraOutputStream|) + (PRETTYPRINT |form| |$algebraOutputStream|))) + |form|) + ('T + (COND + ((NULL |$collectOutput|) + (PRETTYPRINT |u| |$algebraOutputStream|))) + NIL))))))))) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}