-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2022, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical ALgorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import sys_-utility import sys_-macros namespace BOOT --Modified JHD February 1993: see files miscout.input for some tests of this -- General principle is that maprin0 is the top-level routine, -- which calls maprinChk to print the object (placing certain large -- matrices on a look-aside list), then calls maprinRows to print these. -- These prints call maprinChk recursively, and maprinChk has to ensure that -- we do not end up in an infinite recursion: matrix1 = matrix2 ... --% Output display routines $defaultSpecialCharacters == [ abstractChar( 28), -- upper left corner abstractChar( 27), -- upper right corner abstractChar( 30), -- lower left corner abstractChar( 31), -- lower right corner abstractChar( 79), -- vertical bar abstractChar( 45), -- horizontal bar abstractChar(144), -- APL quad abstractChar(173), -- left bracket abstractChar(189), -- right bracket abstractChar(192), -- left brace abstractChar(208), -- right brace abstractChar( 59), -- top box tee abstractChar( 62), -- bottom box tee abstractChar( 63), -- right box tee abstractChar( 61), -- left box tee abstractChar( 44), -- center box tee abstractChar(224) -- back slash ] $plainSpecialCharacters0 == [ abstractChar( 78), -- upper left corner (+) abstractChar( 78), -- upper right corner (+) abstractChar( 78), -- lower left corner (+) abstractChar( 78), -- lower right corner (+) abstractChar( 79), -- vertical bar abstractChar( 96), -- horizontal bar (-) abstractChar(111), -- APL quad (?) abstractChar(173), -- left bracket abstractChar(189), -- right bracket abstractChar(192), -- left brace abstractChar(208), -- right brace abstractChar( 78), -- top box tee (+) abstractChar( 78), -- bottom box tee (+) abstractChar( 78), -- right box tee (+) abstractChar( 78), -- left box tee (+) abstractChar( 78), -- center box tee (+) abstractChar(224) -- back slash ] $plainSpecialCharacters1 == [ abstractChar(107), -- upper left corner (,) abstractChar(107), -- upper right corner (,) abstractChar(125), -- lower left corner (') abstractChar(125), -- lower right corner (') abstractChar( 79), -- vertical bar abstractChar( 96), -- horizontal bar (-) abstractChar(111), -- APL quad (?) abstractChar(173), -- left bracket abstractChar(189), -- right bracket abstractChar(192), -- left brace abstractChar(208), -- right brace abstractChar( 78), -- top box tee (+) abstractChar( 78), -- bottom box tee (+) abstractChar( 78), -- right box tee (+) abstractChar( 78), -- left box tee (+) abstractChar( 78), -- center box tee (+) abstractChar(224) -- back slash ] $plainSpecialCharacters2 == [ abstractChar( 79), -- upper left corner (|) abstractChar( 79), -- upper right corner (|) abstractChar( 79), -- lower left corner (|) abstractChar( 79), -- lower right corner (|) abstractChar( 79), -- vertical bar abstractChar( 96), -- horizontal bar (-) abstractChar(111), -- APL quad (?) abstractChar(173), -- left bracket abstractChar(189), -- right bracket abstractChar(192), -- left brace abstractChar(208), -- right brace abstractChar( 78), -- top box tee (+) abstractChar( 78), -- bottom box tee (+) abstractChar( 78), -- right box tee (+) abstractChar( 78), -- left box tee (+) abstractChar( 78), -- center box tee (+) abstractChar(224) -- back slash ] $plainSpecialCharacters3 == [ abstractChar( 96), -- upper left corner (-) abstractChar( 96), -- upper right corner (-) abstractChar( 96), -- lower left corner (-) abstractChar( 96), -- lower right corner (-) abstractChar( 79), -- vertical bar abstractChar( 96), -- horizontal bar (-) abstractChar(111), -- APL quad (?) abstractChar(173), -- left bracket abstractChar(189), -- right bracket abstractChar(192), -- left brace abstractChar(208), -- right brace abstractChar( 78), -- top box tee (+) abstractChar( 78), -- bottom box tee (+) abstractChar( 78), -- right box tee (+) abstractChar( 78), -- left box tee (+) abstractChar( 78), -- center box tee (+) abstractChar(224) -- back slash ] $plainRTspecialCharacters == [ '_+, -- upper left corner (+) '_+, -- upper right corner (+) '_+, -- lower left corner (+) '_+, -- lower right corner (+) '_|, -- vertical bar '_-, -- horizontal bar (-) '_?, -- APL quad (?) '_[, -- left bracket '_], -- right bracket '_{, -- left brace '_}, -- right brace '_+, -- top box tee (+) '_+, -- bottom box tee (+) '_+, -- right box tee (+) '_+, -- left box tee (+) '_+, -- center box tee (+) '_\ -- back slash ] ++ End of Transmission character; usually to the Algebra Output ++ Stream in lean mode. $RecordSeparator == abstractChar 30 macro makeCharacter n == makeSymbol(charString abstractChar n) $RTspecialCharacters == [ makeCharacter 218, -- upper left corner (+) makeCharacter 191, -- upper right corner (+) makeCharacter 192, -- lower left corner (+) makeCharacter 217, -- lower right corner (+) makeCharacter 179, -- vertical bar makeCharacter 196, -- horizontal bar (-) $quadSymbol, -- APL quad (?) '_[, -- left bracket '_], -- right bracket '_{, -- left brace '_}, -- right brace makeCharacter 194, -- top box tee (+) makeCharacter 193, -- bottom box tee (+) makeCharacter 180, -- right box tee (+) makeCharacter 195, -- left box tee (+) makeCharacter 197, -- center box tee (+) '_\ -- back slash ] $specialCharacters := $RTspecialCharacters $specialCharacterAlist == '( (ulc . 0)_ (urc . 1)_ (llc . 2)_ (lrc . 3)_ (vbar . 4)_ (hbar . 5)_ (quad . 6)_ (lbrk . 7)_ (rbrk . 8)_ (lbrc . 9)_ (rbrc . 10)_ (ttee . 11)_ (btee . 12)_ (rtee . 13)_ (ltee . 14)_ (ctee . 15)_ (bslash . 16)_ ) MATBORCH == '"*" _*TALLPAR := false --% Output functions dispatch tables. for x in '((+ WIDTH sumWidth) (_- APP appneg) (_- WIDTH minusWidth) (_/ APP appfrac) (_/ SUBSPAN fracsub) (_/ SUPERSPAN fracsuper) (_/ WIDTH fracwidth) (AGGSET APP argsapp) (AGGSET SUBSPAN agggsub) (AGGSET SUPERSPAN agggsuper) (AGGSET WIDTH agggwidth) (binom APP binomApp) (binomSUBSPAN binomSub) (binom SUPERSPAN binomSuper) (binom WIDTH binomWidth) (ALTSUPERSUB APP altSuperSubApp) (ALTSUPERSUB SUBSPAN altSuperSubSub) (ALTSUPERSUB SUPERSPAN altSuperSubSuper) (ALTSUPERSUB WIDTH altSuperSubWidth) (BOX APP boxApp) (BOX SUBSPAN boxSub) (BOX SUPERSPAN boxSuper) (BOX WIDTH boxWidth) (BRACKET SUBSPAN qTSub) (BRACKET SUPERSPAN qTSuper) (BRACKET WIDTH qTWidth) (CENTER APP centerApp) (EXT APP appext) (EXT SUBSPAN extsub) (EXT SUPERSPAN extsuper) (EXT WIDTH extwidth) (MATRIX APP appmat) (MATRIX SUBSPAN matSub) (MATRIX SUPERSPAN matSuper) (MATRIX WIDTH matWidth) (NOTHING APP nothingApp) (NOTHING SUPERSPAN nothingSuper) (NOTHING SUBSPAN nothingSub) (NOTHING WIDTH nothingWidth) (OVER APP appfrac) (OVER SUBSPAN fracsub) (OVER SUPERSPAN fracsuper) (OVER WIDTH fracwidth) (OVERLABEL APP overlabelApp) (OVERLABEL SUPERSPAN overlabelSuper) (OVERLABEL WIDTH overlabelWidth) (OVERBAR APP overbarApp) (OVERBAR SUPERSPAN overbarSuper) (OVERBAR WIDTH overbarWidth) (PAREN APP appparu1) (PAREN SUBSPAN qTSub) (PAREN SUPERSPAN qTSuper) (PAREN WIDTH qTWidth) (ROOT APP rootApp) (ROOT SUBSPAN rootSub) (ROOT SUPERSPAN rootSuper) (ROOT WIDTH rootWidth) (ROW WIDTH eq0) (SC APP appsc) (SC SUBSPAN agggsub) (SC SUPERSPAN agggsuper) (SC WIDTH widthSC) (SETQ APP appsetq) (SETQ WIDTH letWidth) (SLASH APP slashApp) (SLASH SUBSPAN slashSub) (SLASH SUPERSPAN slashSuper) (SLASH WIDTH slashWidth) (SUB APP appsub) (SUB SUBSPAN subSub) (SUB SUPERSPAN subSuper) (SUB WIDTH suScWidth) (SUPERSUB APP superSubApp) (SUPERSUB SUBSPAN superSubSub) (SUPERSUB SUPERSPAN superSubSuper) (SUPERSUB WIDTH superSubWidth) (VCONCAT APP vconcatapp) (VCONCAT SUBSPAN vConcatSub) (VCONCAT SUPERSPAN vConcatSuper) (VCONCAT WIDTH vConcatWidth) (BINOMIAL APP binomialApp) (BINOMIAL SUBSPAN binomialSub) (BINOMIAL SUPERSPAN binomialSuper) (BINOMIAL WIDTH binomialWidth) (ZAG APP zagApp) (ZAG SUBSPAN zagSub) (ZAG SUPERSPAN zagSuper) (ZAG WIDTH zagWidth)) repeat property(first x, second x) := third x for x in '((+ APP plusApp) (* APP timesApp) (* WIDTH timesWidth) (** APP exptApp) (** WIDTH exptWidth) (** SUBSPAN exptSub) (** SUPERSPAN exptSuper) (_^ APP exptApp) (_^ WIDTH exptWidth) (_^ SUBSPAN exptSub) (_^ SUPERSPAN exptSuper) (STEP APP stepApp) (STEP WIDTH stepWidth) (STEP SUBSPAN stepSub) (STEP SUPERSPAN stepSuper) (IN APP inApp) (IN WIDTH inWidth) (IN SUBSPAN inSub) (IN SUPERSPAN inSuper) (AGGLST APP aggApp) (AGGLST SUBSPAN aggSub) (AGGLST SUPERSPAN aggSuper) (CONCATB APP concatbApp) (CONCATB SUBSPAN concatSub) (CONCATB SUPERSPAN concatSuper) (CONCATB WIDTH concatbWidth) (CONCAT APP concatApp) (CONCAT SUBSPAN concatSub) (CONCAT SUPERSPAN concatSuper) (CONCAT WIDTH concatWidth) (QUOTE APP quoteApp) (QUOTE SUBSPAN quoteSub) (QUOTE SUPERSPAN quoteSuper) (QUOTE WIDTH quoteWidth) (STRING APP stringApp) (STRING SUBSPAN eq0) (STRING SUPERSPAN eq0) (STRING WIDTH stringWidth) (SIGMA APP sigmaApp) (SIGMA SUBSPAN sigmaSub) (SIGMA SUPERSPAN sigmaSup) (SIGMA WIDTH sigmaWidth) (SIGMA2 APP sigma2App) (SIGMA2 SUBSPAN sigma2Sub) (SIGMA2 SUPERSPAN sigma2Sup) (SIGMA2 WIDTH sigma2Width) (INTSIGN APP intApp) (INTSIGN SUBSPAN intSub) (INTSIGN SUPERSPAN intSup) (INTSIGN WIDTH intWidth) (INDEFINTEGRAL APP indefIntegralApp) (INDEFINTEGRAL SUBSPAN indefIntegralSub) (INDEFINTEGRAL SUPERSPAN indefIntegralSup) (INDEFINTEGRAL WIDTH indefIntegralWidth) (PI APP piApp) (PI SUBSPAN piSub) (PI SUPERSPAN piSup) (PI WIDTH piWidth) (PI2 APP pi2App) (PI2 SUBSPAN pi2Sub) (PI2 SUPERSPAN pi2Sup) (PI2 WIDTH pi2Width) (AGGLST WIDTH aggWidth) (BRACKET APP bracketApp) (BRACE APP braceApp) (BRACE WIDTH qTWidth)) repeat property(first x, second x) := third x for x in ["*","+","AND","OR","PROGN"] repeat property(x,'NARY) := true for x in '((_= "=") (_: ":") (_not "not ") (_| " | ") (_SEGMENT "..")) repeat property(first x,'PREFIXOP) := second x for x in '((_:_= " := ") (_/ "/") (_+ "+") (_* "*") (_*_* "**") (_^ "^") (_: ":") (_:_: "::") (_@ "@") (SEL ".") (_exquo " exquo ") (_div " div ") (_quo " quo ") (_rem " rem ") (_case " case ") (_and " and ") (_/_\ " /\ ") (_or " or ") (_\_/ " \/ ") (TAG ": ") (_+_-_> " +-> ") (RARROW " -> ") (SEGMENT "..") (_in " in ") (EL* ":") (JOIN " JOIN ") (EQUATNUM " ") (IQUOTIENT "//") (_= "= ") (_>_= " >= ") (_> " > ") (_<_= " <= ") (_< " < ") (_| " | ") (_+ " + ") (_- " - ") (MEMBER " in ") (NMEMBER " nin ") (WHERE " WHERE ") (AT " AT ") (MAX " MAX ") (MIN " MIN ")) repeat property(first x,'INFIXOP) := second x property('TAG,'Led) := '(TAG TAG 122 121) property('EQUATNUM,'Nud) := '(dummy dummy 0 0) property('EQUATNUM,'Led) := '(dummy dummy 10000 0) property('%LET,'Led) := '(_:_= %LET 125 124) property('RARROW,'Led) := '(_=_= DEF 122 121) property('SEGMENT,'Led) := '(_._. SEGMENT 401 699 (P_:Seg)) property('SEGMENT,'isSuffix) := true property('EQUAL1,'CHRYBNAM) := 'EQ property('COND,'Nud) := '(_if _if 130 0) property('CONS,'Led) := '(CONS CONS 1000 1000) property('APPEND,'Led) := '(APPEND APPEND 1000 1000) --% $collectOutput := false ++ Start a a new line if we are in 2-d ASCII art display mode. newlineIfDisplaying() == if not $collectOutput then writeNewline $algebraOutputStream specialChar(symbol) == -- looks up symbol in $specialCharacterAlist, gets the index -- into the abstractChar table, and returns the appropriate character null (code := IFCDR objectAssoc(symbol,$specialCharacterAlist)) => '"?" $specialCharacters.code rbrkSch() == symbolName specialChar 'rbrk lbrkSch() == symbolName specialChar 'lbrk quadSch() == symbolName specialChar 'quad ++ List of binary operators $BinaryOperators == ["**", "^", "*", "/", "//", "\", "\\", "rem", "quo", "exquo", "+", "-", "/\", "\/", "=", "~=", "<", "<=", ">", ">=", "and", "or", ">>", "<<", "by", "has", "case", "->", "..", "|"] binaryInfix? x == ident? x => symbolMember?(x,$BinaryOperators) string? x => symbolMember?(makeSymbol x,$BinaryOperators) false 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 == o isnt [.,:.] => string? o => o o = " " => '" " o = ")" => '")" o = "(" => '"(" STRINGIMAGE o apply(function strconc,[obj2String o' for o' in o]) APP(u,x,y,d) == u isnt [.,:.] => appChar(atom2String u,x,y,d) u is [[op,:.],a] and (s:= GETL(op,'PREFIXOP)) => GETL(op,'isSuffix) => appChar(s,x+WIDTH a,y,APP(a,x,y,d)) APP(a,x+#s,y,appChar(s,x,y,d)) u is [[id,:.],:.] => fn := GETL(id,'APP) => apply(fn,[u,x,y,d]) not integer? id and (d':= appInfix(u,x,y,d))=> d' appelse(u,x,y,d) appelse(u,x,y,d) atom2String x == ident? x => symbolName x string? 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 stringChar(string,0) = char "%" then stringChar(string,1) = char "b" => bumpDeltaIfTrue:= true stringChar(string,1) = char "d" => bumpDeltaIfTrue:= true 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,append!(d,[[y,:makeString(10+$LINELENGTH+$MARGIN,char " ")]])) print(x,domain) == dom:= devaluate domain $InteractiveMode: local:= true $dontDisplayEquatnum: local:= true output(x,dom) ++ Write x as an asgard form on the standard output. outputAsgardForm(x,t) == f := ['%OBJECT,x,devaluate t] WRITE(f,stream <- $algebraOutputStream) freshLine $algebraOutputStream mathprintWithNumber(x,t) == x:= outputTran x $asgardForm => outputAsgardForm(x,t) maprin $IOindex => ['EQUATNUM,$IOindex,x] x mathprint(x,out == $OutputStream) == x := outputTran x maprin x sayMath u == for x in u repeat acc:= concat(acc,linearFormatName x) sayMSG acc --% Output transformations outputTran x == member(x,'("failed" "nil" "prime" "sqfr" "irred")) => strconc('"_"",x,'"_"") string? x => x vector? x => outputTran ['BRACKET,['AGGLST,:[x.i for i in 0..maxIndex x]]] integer? x => x < 0 => ["-",MINUS x] x x isnt [.,:.] => x=$EmptyMode => specialChar 'quad x x is [c,var,mode] and c in '(_pretend _: _:_: _@) => var := outputTran var if cons? 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 integer? x and integer? y and integer? z and z > 0 and (float := getFunctionFromDomain("float",domain,[$Integer,$Integer,$PositiveInteger])) => f := SPADCALL(x,y,z,float) o := coerceInteractive(objNewWrap(f, domain), '(OutputForm)) objValUnwrap o [op,:l]:= flattenOps x --needed since "op" is string in some spad code if string? op then (op := makeSymbol 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 integer? 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 integer?(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 := second foo2 ["**", outputTran foo4, outputTran foo3] op = 'IF => outputTranIf x op = 'COLLECT => outputTranCollect x op = 'REDUCE => outputTranReduce x op = 'REPEAT => outputTranRepeat x op = 'SEQ => outputTranSEQ x op in '(cons nconc) => outputConstructTran x l:= [outputTran y for y in l] op = "*" => l is [a] => outputTran a l is [["-",a],:b] => -- now this is tricky because we've already outputTran the list -- expect trouble when outputTran hits b again -- some things object to being outputTran twice ,e.g.matrices -- same thing a bit lower down for "/" a=1 => outputTran ["-",[op,:b]] outputTran ["-",[op,a,:b]] [op,:"append"/[(ss is ["*",:ll] => ll; [ss]) for ss in l]] op = "+" => l is [a] => outputTran a [op,:"append"/[(ss is ["+",:ll] => ll; [ss]) for ss in l]] op = "/" => if $fractionDisplayType = 'horizontal then op := 'SLASH else op := 'OVER l is [["-",a],:b] => outputTran ["-",[op,a,:b]] [outputTran op,:l] op="|" and l is [["tuple",:u],pred] => ['PAREN,["|",['AGGLST,:l],pred]] op="tuple" => ['PAREN,['AGGLST,:l]] op='LISTOF => ['AGGLST,:l] ident? op and not (op in '(_* _*_*) ) and char "*" = stringChar(symbolName 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 member(op,['"+",'"*","+","*"]) => [op,:checkArgs(op,args)] l checkArgs(op,tail) == head := [] while tail repeat term := first tail term isnt [.,:.] => head := [term,:head] tail := rest tail not LISTP term => -- never happens? head := [term,:head] tail := rest tail op=first term => tail := [:rest term,:rest tail] head := [term,:head] tail := rest tail reverse head outputTranSEQ ['SEQ,:l,exitform] == if exitform is ['exit,.,a] then exitform := a ['SC,:[outputTran x for x in l],outputTran exitform] outputTranIf ['IF,x,y,z] == y = '%noBranch => ['CONCATB,'if,['CONCATB,'not,outputTran x],'then,outputTran z] z = '%noBranch => ['CONCATB,'if,outputTran x,'then,outputTran y] y' := outputTran y z' := outputTran z --y' is ['SC,:.] or z' is ['SC,:.] => -- ['CONCATB,'if,outputTran x, -- ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] --['CONCATB,'if,outputTran x,'then,outputTran y,'else,outputTran z] ['CONCATB,'if,outputTran x, ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] outputMapTran l == null l => nil -- should not happen -- display subscripts linearly $linearFormatScripts : local := true -- get the real names of the parameters alias := get($op,'alias,$InteractiveFrame) rest l => -- if multiple forms, call repeatedly ['SC,:[outputMapTran0(ll,alias) for ll in l]] outputMapTran0(first l,alias) outputMapTran0(argDef,alias) == arg := first argDef def := rest argDef [arg',:def'] := simplifyMapPattern(argDef,alias) arg' := outputTran arg' if null arg' then arg' := '"()" ['CONCATB,$op,outputTran arg',"==",outputTran def'] outputTranReduce ['REDUCE,op,.,body] == ['CONCAT,op,"/",outputTran body] outputTranRepeat ["REPEAT",:itl,body] == body' := outputTran body itl => itlist:= outputTranIteration itl ['CONCATB,itlist,'repeat,body'] ['CONCATB,'repeat,body'] outputTranCollect [.,:itl,body] == itlist:= outputTranIteration itl ['BRACKET,['CONCATB,outputTran body,itlist]] outputTranIteration itl == null rest itl => outputTranIterate first itl ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl] outputTranIterate x == x is ['STEP,n,init,step,:final] => init' := outputTran init if LISTP init then init' := ['PAREN,init'] final' := final => LISTP first final => [['PAREN,outputTran first final]] [outputTran first final] nil ['STEP,outputTran n,init',outputTran step,:final'] x is ["IN",n,s] => ["IN",outputTran n,outputTran s] x is [op,p] and op in '(_| UNTIL WHILE) => op:= DOWNCASE op ['CONCATB,op,outputTran p] throwKeyedMsg("S2IX0008",['outputTranIterate,['"illegal iterate: ",x]]) outputConstructTran x == x is [op,a,b] => a:= outputTran a b:= outputTran b op="cons" => b is ['construct,:l] => ['construct,a,:l] ['BRACKET,['AGGLST,:[a,[":",b]]]] op="nconc" => aPart := a is ['construct,c] and c is ['SEGMENT,:.] => c [":",a] b is ['construct,:l] => ['construct,aPart,:l] ['BRACKET,['AGGLST,aPart,[":",b]]] [op,a,b] x isnt [.,:.] => x [outputTran first x,:outputConstructTran rest x] outputTranMatrix x == not vector? 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 vector? 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 := [(string? f => f; STRINGIMAGE f) -- for f in linearFormatForm(op,argl)] -- strconc/l s:= PNAME op indexList:= [readInteger PNAME d for i in 1.. while (digit? (d:= s.(idxmax:= i)))] cleanOp:= makeSymbol (strconc/[PNAME s.i for i in idxmax..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 := [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 not 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:= arg isnt [.,:.] and not integer? arg or isRationalNumber arg wasQuotient:= isQuotient op wasNumber:= integer? arg lastOp := op firstTime:= nil d needBlankForRoot(lastOp,op,arg) == lastOp ~= "^" and lastOp ~= "**" and not(subspan(arg)>0) => false op = "**" and keyp second arg = 'ROOT => true op = "^" and keyp second 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 == a isnt [.,:.] and null (integer? a and a < 0) => false key:= keyp a key = "OVER" => true -- added JHD 2/Aug/90 (key="SUB") or (null GETL(key,"Nud") and null GETL(key,"Led")) => false true exptSub u == subspan second 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 => cur isnt [.,:.] or keyp cur="SUB" or isRationalNumber cur or op="**" or op = "^" or (op isnt [.,:.] and not integer? op and null GETL(op,"APP")) wasNumber => integer?(cur) or isRationalNumber cur or ((op="**" or op ="^") and integer?(second 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 not 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:= arg isnt [.,:.] and not integer? arg --or isRationalNumber arg wasQuotient:= isQuotient op wasNumber:= integer? arg firstTime:= nil w plusApp([.,frst,:rst],x,y,d) == appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d)) appSum(u,x,y,d) == for arg in u repeat infixOp:= syminusp arg => "-" "+" opString:= GETL(infixOp,"INFIXOP") or '"," d:= APP(opString,x,y,d) x:= x+WIDTH opString arg:= absym arg --negate a neg. number or remove leading "-" rightPrec:= getOpBindingPower(infixOp,"Led","right") if infixOp = "-" then rightPrec:=rightPrec +1 -- that +1 added JHD 2 Aug 89 to prevent x-(y+z) printing as x-y+z -- Sutor found the example: -- )cl all -- p : P[x] P I := x - y - z -- p :: P[x] FR P I -- trailingCoef % [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg d appInfix(e,x,y,d) == op := keyp e leftPrec:= getOpBindingPower(op,"Led","left") leftPrec = 1000 => return nil --no infix operator is allowed default value rightPrec:= getOpBindingPower(op,"Led","right") #e < 2 => throwKeyedMsg("S2IX0008",['appInfix, '"fewer than 2 arguments to an infix function"]) opString:= GETL(op,"INFIXOP") or '"," opWidth:= WIDTH opString [.,frst,:rst]:= e null rst => GETL(op,"isSuffix") => [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) d:= appChar(opString,x,y,d) THROW('outputFailure,'outputFailure) [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) --app in left arg for arg in rst repeat d:= appChar(opString,x,y,d) --app in the infix operator x:= x+opWidth [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",opString) --app in right arg d appconc(d,x,y,w) == append!(d,[[[x,:y],:w]]) infixArgNeedsParens(arg, prec, leftOrRight) == prec > getBindingPowerOf(leftOrRight, arg) + 1 appInfixArg(u,x,y,d,prec,leftOrRight,string) == insertPrensIfTrue:= infixArgNeedsParens(u,prec,leftOrRight) d:= insertPrensIfTrue => appparu(u,x,y,d) APP(u,x,y,d) x:= x+WIDTH u if string then d:= appconc(d,x,y,string) [d,(insertPrensIfTrue => x+2; x)] leftBindingPowerOf(x, ind) == y := GETL(x, ind) y => ELEMN(y, 3, 0) 0 rightBindingPowerOf(x, ind) == y := GETL(x, ind) y => ELEMN(y, 4, 105) 105 getBindingPowerOf(key,x) == --binding powers can be found in file NEWAUX LISP x is ['REDUCE,:.] => (key='left => 130; key='right => 0) x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) x is ['%when,:.] => (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 widthOfString u == u = $EmptyString => 0 stringChar(u,0) = char "%" and (stringChar(u,1) = char "b" or stringChar(u,1) = char "d") => 1 #u outformWidth u == --WIDTH as called from OUTFORM to do a COPY string? u => widthOfString u u isnt [.,:.] => # atom2String u WIDTH copyTree u WIDTH u == string? u => widthOfString u integer? u => if (u < 1) then negative := 1 u := -u else negative := 0 -- Try and be fairly exact for smallish integers: u = 0 => 1 u < $DoubleFloatMaximum => 1+negative+FLOOR ((log10 u) + 0.0000001) -- Rough guess: integer-length returns log2 rounded up, so divide it by -- roughly log2(10). This should return an over-estimate, but for objects -- this big does it matter? FLOOR(INTEGER_-LENGTH(u)/3.3) u isnt [.,:.] => # atom2String u putWidth u is [[.,:n],:.] => n THROW('outputFailure,'outputFailure) putWidth u == u isnt [.,:.] or u is [[.,:n],:.] and integer? n => u op:= keyp u --integer? op => nil leftPrec:= getBindingPowerOf("left",u) rightPrec:= getBindingPowerOf("right",u) [firstEl,:l] := u interSpace:= symbol? firstEl and GETL(firstEl,"INFIXOP") => 0 1 argsWidth:= l is [firstArg,:restArg] => u.rest.first := putWidth firstArg for y in tails restArg repeat y.first := 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:= (oldFirst:= first u) isnt [.,:.] => fn:= GETL(oldFirst,"WIDTH") => [oldFirst,:apply(fn,[[oldFirst,:l]])] if l then ll := rest l else ll := nil [oldFirst,:opWidth(oldFirst,ll)+argsWidth] [putWidth oldFirst,:2+WIDTH oldFirst+argsWidth] u.first := newFirst u opWidth(op,has2Arguments) == op = "EQUATNUM" => 4 integer? op => 2 + # STRINGIMAGE op null has2Arguments => a:= GETL(op,"PREFIXOP") => # a 2 + # PNAME op a:= GETL(op,"INFIXOP") => # a 2 + # 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 $demoFlag := false 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) $leanMode and WRITE($RecordSeparator,stream <- $algebraOutputStream) 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 x isnt [.,:.] and (u:= assoc(x,$MatrixList)) => $MatrixList := remove($MatrixList,u) maPrin deMatrix rest 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 := remove($MatrixList,u) maPrin ["=",arg, deMatrix rest 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] ident? 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 := remove($MatrixList,u) maPrin ['EQUATNUM,n,rest u] newlineIfDisplaying() maPrin x maPrin x -- above line added JHD 13/2/93 since otherwise x gets lost maprinRows matrixList == newlineIfDisplaying() while matrixList repeat y := reverse! 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 newlineIfDisplaying() 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 u isnt [.,:.] => 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 op in '(%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 rest 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 op in '(_+ _* ) => --Each of these prints the first argument in a width 3 smaller (ans:=LargeMatrixp(second u,width-3,dist)) => largeMatrixAlist ans n:=3+WIDTH second 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 rest 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 m = rest v => return first v name => name name := makeSymbol strconc('"matrix",toString($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 u isnt [.,:.] => 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(rest l,m) u := -- rest 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'] op isnt [.,:.] => [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:= a isnt [.,:.] => [a] [SubstWhileDesizing(a,m)] tail:=res for i in b repeat if i isnt [.,:.] then tail.rest := [i] else tail.rest := [SubstWhileDesizing(i,m)] tail:=rest tail res u --% Printing of Sigmas , Pis and Intsigns sigmaSub u == --The depth function for sigmas with lower limit only MAX(1 + height second u, subspan third u) sigmaSup u == --The height function for sigmas with lower limit only MAX(1, superspan third 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 macro half x == x quo 2 bigopAppAux(bot,top,arg,x,y,d,kind) == botWidth := (bot => WIDTH bot; 0) topWidth := WIDTH top opWidth := kind = 'pi => 5 3 maxWidth := MAX(opWidth,botWidth,topWidth) xCenter := half(maxWidth-1) + x d:=APP(arg,x+2+maxWidth,y,d) d:= bot isnt [.,:.] and # atom2String bot = 1 => APP(bot,xCenter,y-2,d) APP(bot,x + half(maxWidth - botWidth),y-2-superspan bot,d) if top then d:= top isnt [.,:.] and # atom2String top = 1 => APP(top,xCenter,y+2,d) APP(top,x + half(maxWidth - topWidth),y+2+subspan top,d) delta := (kind = 'pi => 2; 1) opCode := kind = 'sigma => [['(0 . 0),:'">"],_ ['(0 . 1),:specialChar('hbar)],_ ['(0 . -1),:specialChar('hbar)],_ ['(1 . 1),:specialChar('hbar)],_ ['(1 . -1),:specialChar('hbar)],_ ['(2 . 1),:specialChar('urc )],_ ['(2 . -1),:specialChar('lrc )]] kind = 'pi => [['(0 . 1),:specialChar('ulc )],_ ['(1 . 0),:specialChar('vbar)],_ ['(1 . 1),:specialChar('ttee)],_ ['(1 . -1),:specialChar('vbar)],_ ['(2 . 1),:specialChar('hbar)],_ ['(3 . 0),:specialChar('vbar)],_ ['(3 . 1),:specialChar('ttee)],_ ['(3 . -1),:specialChar('vbar)],_ ['(4 . 1),:specialChar('urc )]] THROW('outputFailure,'outputFailure) xLate(opCode,xCenter - delta,y,d) sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma) sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma) sigma2Sub u == --The depth function for sigmas with 2 limits MAX(1 + height second u, subspan fourth u) sigma2Sup u == --The depth function for sigmas with 2 limits MAX(1 + height third u, superspan fourth u) piSub u == --The depth function for pi's (products) MAX(1 + height second u, subspan third u) piSup u == --The height function for pi's (products) MAX(1, superspan third 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 second u, subspan fourth u) pi2Sup u == --The depth function for pi's with 2 limits MAX(1 + height third u, superspan fourth 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 := (x + endPoint) quo 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 => sayMSG ['"%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 l.rest := nil [list,:splitConcat(x,maxWidth,nil)] spadPrint(x,m) == m = $NoValueMode => x newlineIfDisplaying() output(x,m) newlineIfDisplaying() texFormat expr == tf := $TexFormat formatFn := getFunctionFromDomain("convert",tf,[$OutputForm,$Integer]) displayFn := getFunctionFromDomain("display",tf,[tf]) SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn) finishLine $texOutputStream nil texFormat1 expr == tf := $TexFormat formatFn := getFunctionFromDomain("coerce",tf, [$OutputForm]) displayFn := getFunctionFromDomain("display",tf,[tf]) SPADCALL(SPADCALL(expr,formatFn),displayFn) finishLine $texOutputStream nil mathmlFormat expr == mml := $MathMLFormat mmlrep := $String formatFn := getFunctionFromDomain("coerce",mml,[$OutputForm]) displayFn := getFunctionFromDomain("display",mml,[mmlrep]) SPADCALL(SPADCALL(expr,formatFn),displayFn) finishLine $mathmlOutputStream nil output(expr,domain) == if isWrapped expr then expr := unwrap expr isMapExpr expr => if $texFormat then texFormat expr if $mathmlFormat then mathmlFormat expr if $algebraFormat then mathprintWithNumber(expr,domain) categoryForm? domain or member(domain,'((Mode) (Domain) (Type))) => if $algebraFormat then mathprintWithNumber(outputDomainConstructor expr,domain) if $texFormat then texFormat outputDomainConstructor expr T := coerceInteractive(objNewWrap(expr,domain),$OutputForm) => x := objValUnwrap T if $fortranFormat then dispfortexp x if not $collectOutput then writeNewline $fortranOutputStream flushOutput $fortranOutputStream if $algebraFormat then mathprintWithNumber(x,domain) if $texFormat then texFormat x if $mathmlFormat then mathmlFormat x sayMSG [:bright '"LISP",'"output:",'"%l",expr or '"NIL"] outputNumber(start,linelength,num) == if start > 1 then blnks := fillerSpaces(start-1,char " ") else blnks := '"" under := '"__" firsttime:=(linelength>3) if linelength>2 then linelength:=linelength-1 while # num > linelength repeat if $collectOutput then $outputLines := [strconc(blnks, subString(num,0,linelength),under), :$outputLines] else sayMSG [blnks, subString(num,0,linelength),under] num := subString(num,linelength) if firsttime then blnks:=strconc(blnks,'" ") linelength:=linelength-1 firsttime:=nil if $collectOutput then $outputLines := [strconc(blnks, num), :$outputLines] else sayMSG [blnks, num] outputString(start,linelength,str) == if start > 1 then blnks := fillerSpaces(start-1,char " ") else blnks := '"" while # str > linelength repeat if $collectOutput then $outputLines := [strconc(blnks, subString(str,0,linelength)), :$outputLines] else sayMSG [blnks, subString(str,0,linelength)] str := subString(str,linelength) if $collectOutput then $outputLines := [strconc(blnks, str), :$outputLines] else sayMSG [blnks, str] outputDomainConstructor form == if VECTORP form then form := devaluate form (u:= prefix2String form) isnt [.,:.] => u v:= [object2String(x) for x in u] return makeSymbol apply(function strconc,v) getOutputAbbreviatedForm form == form is [op,:argl] => op is "Mapping" => formatMapping argl builtinConstructor? op => outputDomainConstructor form u := getConstructorAbbreviationFromDB op or op null argl => u ml:= getPartialConstructorModemapSig(op) argl:= [fn for x in argl for m in ml] where fn() == categoryForm?(m) => outputDomainConstructor x x' := coerceInteractive(objNewWrap(x,m),$OutputForm) x' => objValUnwrap x' '"unprintableObject" [u,:argl] form outputOp x == x is [op,:args] and (GETL(op,"LED") or GETL(op,"NUD")) => n:= GETL(op,"NARY") => 2 #args newop:= makeSymbol strconc('"*",toString 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 newlineIfDisplaying() isInitialMap u == u is [[[n],.],:l] and integer? n and (and/[x is [[ =i],.] for x in l for i in n+1..]) printMap1(x,initialFlag) == initialFlag => printBasic second x if CDAR x then printBasic first x else printBasic CAAR x printBasic " E " printBasic second x printBasic x == x=$One => writeInteger(1,$algebraOutputStream) x=$Zero => writeInteger(0,$algebraOutputStream) ident? x => writeString(symbolName x,$algebraOutputStream) x isnt [.,:.] => PRIN1(x,$algebraOutputStream) PRIN1(x,$algebraOutputStream) charybdis(u,start,linelength) == keyp u='EQUATNUM and null (CDDR u) => charybdis(['PAREN,u.1],start,linelength) charyTop(u,start,linelength) charyTop(u,start,linelength) == u is ['SC,:l] or u is [['SC,:.],:l] => for a in l repeat charyTop(a,start,linelength) '" " u is [['CONCATB,:.],:m,[['SC,:.],:l]] => charyTop(['CONCATB,:m],start,linelength) charyTop(['SC,:l],start+2,linelength-2) u is ['CENTER,a] => b := charyTopWidth a (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength) charyTop(b,half(linelength-start-w),linelength) v := charyTopWidth u 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 reverse! sortBy(function first,d),:$testOutputLineList] until n < m repeat scylla(n,d) n := n - 1 '" " charyTopWidth u == u isnt [.,:.] => u first u isnt [.,:.] => putWidth u integer? 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) == integer? u => outputNumber(start,linelength,atom2String u) u isnt [.,:.] => outputString(start,linelength,atom2String u) sameObject?(x:= keyp u,'_-) => charyMinus(u,v,start,linelength) x in '(_+ _* AGGLST) => charySplit(u,v,start,linelength) x='EQUATNUM => charyEquatnum(u,v,start,linelength) d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) x = 'OVER => charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) 3=#u and GETL(x,'Led) => d:= PNAME first GETL(x,'Led) charyBinary(d,u,v,start,linelength) x='CONCAT => concatTrouble(rest v,d,start,linelength,nil) x='CONCATB => (rest v) is [loop, 'repeat, body] => charyTop(['CONCATB,loop,'repeat],start,linelength) charyTop(body,start+2,linelength-2) (rest v) is [wu, loop, 'repeat, body] and (keyp wu) is ['CONCATB,wu',.] and wu' in '(while until) => charyTop(['CONCATB,wu,loop,'repeat],start,linelength) charyTop(body,start+2,linelength-2) concatTrouble(rest v,d,start,linelength,true) GETL(x,'INFIXOP) => charySplit(u,v,start,linelength) x='PAREN and (sameObject?(keyp u.1,'AGGLST) and (v:= ",") or sameObject?(keyp u.1,'AGGSET) and (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)") x='PAREN and sameObject?(keyp u.1,'CONCATB) => bracketagglist(rest u.1,start,linelength," ","_(","_)") x='BRACKET and (sameObject?(keyp u.1,'AGGLST) and (v:= ",")) => bracketagglist(rest u.1,start,linelength,v, specialChar 'lbrk, specialChar 'rbrk) x='BRACE and (sameObject?(keyp u.1,'AGGLST) and (v:= ",")) => bracketagglist(rest u.1,start,linelength,v, specialChar 'lbrc, specialChar 'rbrc) x='EXT => longext(u,start,linelength) x='MATRIX => MATUNWND() x='ELSE => charyElse(u,v,start,linelength) 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) == member(d,'(" := " " = ")) => 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) null (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 dm.rest := nil WIDTH v > linelength - 2 => return nil v.first := first v.0 dm.rest := ddm m := rest m v.first := first v.0 m.rest := nil charybdis(v,start + 2,linelength - 2) split2(u,dm,ddm,start,linelength) split2(u,dm,ddm,start,linelength) == --prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; opSrch(keyp u,OPLIST))) prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; '",")) dm.rest := 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) null (CDDR u) => '" " prnd(start,'",") charybdis(['ELSE,:CDDR v],start,linelength) '" " scylla(n,v) == y := LASSOC(n,v) null y => nil if string?(y) then y := trimTrailingBlank copyString y if $collectOutput then $outputLines := [y, :$outputLines] else PRINC(y,$algebraOutputStream) writeNewline $algebraOutputStream nil keyp(u) == u isnt [.,:.] => nil first u isnt [.,:.] => first u CAAR u absym x == integer? x and (x < 0) => -x cons? x and (keyp(x) = '_-) => second x x agg(n,u) == (n = 1) => second 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 == u isnt [.,:.] => 0 integer? rest u => subspan first u (cons? first u and_ CAAR u isnt [.,:.] and_ not integer? CAAR u and_ GETL(CAAR u, 'SUBSPAN) ) => apply(GETL(CAAR u, 'SUBSPAN), [u]) MAX(subspan first u, subspan rest u) agggsub u == subspan rest u superspan u == u isnt [.,:.] => 0 integer? rest u => superspan first u (cons? first u and_ CAAR u isnt [.,:.] and_ not integer? CAAR u and_ GETL(CAAR u, 'SUPERSPAN) ) => apply(GETL(CAAR u, 'SUPERSPAN), [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) == (null (_*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) == (null (_*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 second u + superspan agg(3,u) + 1) d := APP(second 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 second 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 second u, WIDTH agg(4,u), temp) if first(z := agg(5,u)) is ["EXT",:.] and (n=3 or (n > 3 and cons? 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 == integer? x => x < 0 cons? x and sameObject?(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([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(second 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(second u, x, y, d) temparg2 := APP('":", x + w, y, temparg1) APP(second rest u, x + 2 + w, y, temparg2) appsub(u, x, y, d) == temparg1 := x + WIDTH second u temparg2 := y - 1 - superspan CDDR u temparg3 := APP(second u, x, y, d) appagg(CDDR u, temparg1, temparg2, temparg3) eq0(u) == 0 height(u) == superspan(u) + 1 + subspan(u) extsub(u) == MAX(subspan agg(5, u), height(agg(3, u)), subspan second u ) extsuper(u) == MAX(superspan second u + height agg(4, u), superspan agg(5, u) ) extwidth(u) == n := MAX(WIDTH second u, WIDTH agg(4, u), 1 + WIDTH agg(2, u) + WIDTH agg(3, u) ) nil or (first(z := agg(5, u)) is ["EXT",:.] and _ (n=3 or ((n > 3) and cons? 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 + (1+w - WIDTH second rest u) quo 2 tempy := y - superspan second rest u - 1 temparg3 := APP(second rest u, tempx, tempy, d) temparg4 := apphor(x, x + w - 1, y, temparg3,specialChar('hbar)) APP(second u, x + (1+w - WIDTH second u) quo 2, y + 1 + subspan second u, temparg4) fracsub(u) == height second rest u fracsuper(u) == height second u fracwidth(u) == numw := WIDTH (num := second u) denw := WIDTH (den := third 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(second u),subspan(second rest u)) slashSuper u == MAX(1,superspan(second u),superspan(second rest u)) slashApp(u, x, y, d) == -- to print things as a/b as opposed to -- a -- - -- b temparg1 := APP(second u, x, y, d) temparg2 := APP('"/", x + WIDTH second u, y, temparg1) APP(second rest u, x + 1 + WIDTH second u, y, temparg2) slashWidth(u) == -- to print things as a/b as opposed to -- a -- - -- b 1 + WIDTH second u + WIDTH second rest u longext(u, i, n) == x := reverse u y := first x u := remWidth(REVERSEWOC(['" ",:rest x])) charybdis(u, i, n) newlineIfDisplaying() charybdis(['ELSE, :[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) 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, d) d := appvertline(MATBORCH, x + w + 1, y - b, top, d) boxSub(x) == subspan x.1+1 boxSuper(x) == null rest x => 0 hl := null CDDR x => 0 true => 2 + subspan x.2 + superspan x.2 true => hl+1 + superspan x.1 boxWidth(x) == null rest 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 + (w - WIDTH second rest u) quo 2 deny := y - superspan second rest u - 1 d := APP(second rest u, denx, deny, d) numx := x + (w - WIDTH second u) quo 2 numy := y+1 + subspan second u d := APP(second 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 second rest u zagSuper(u) == height second 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 := second u wl := CDAR w subl := rest second w superl := rest second 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 + (first w - WIDTH first row) quo 2, yc, d) xc := xc + 2 + first w row := rest row w := rest w matSuper(x) == (x := x.1) => -1 + (first x.1 + first x.2) quo 2 true => ERROR('MAT) matSub(x) == (x := x.1) => (-1 + first x.1 + first x.2) quo 2 true => ERROR('MAT) matWidth(x) == y := CDDR x -- list of rows, each of form ((ROW . w) element element ...) numOfColumns := # CDAR y widthList := matLSum2 matWList(y, [0 for . in 1..numOfColumns]) --returns ["max width of entries in column i" for i in 1..numberOfRows] subspanList := matLSum matSubList y superspanList := matLSum matSuperList y x.rest.first := [widthList, subspanList, superspanList] CAAR x.1 matLSum(x) == [sumoverlist x + # x,:x] matLSum2(x) == [sumoverlist x + 2*(# x),:x] matWList(x, y) == null x => y true => matWList(rest x, matWList1(CDAR x, y) ) matWList1(x, y) == null x => nil true => [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 => [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 => [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 := [['CONCAT, open, first u], :[['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 s = -1 => (nextu := nil) sameObject?(lastx, u) => ((nextu := rest u); u.rest := nil) true => ((nextu := lastx); PREDECESSOR(lastx, u).rest := nil) for x in tails u repeat x.first := ['CONCAT, first x, tchr] if null nextu then last(u).rest.rest.first := close x := ASSOCIATER('CONCAT, [ichr,:u]) charybdis(ASSOCIATER('CONCAT, u), start, linelength) newlineIfDisplaying() ichr := '" " u := nextu null u => return(nil) prnd(start, op) == --> $testOutputLineFlag => string := strconc(fillerSpaces MAX(0,start - 1),op) $testOutputLineList := [string,:$testOutputLineList] writeString(fillerSpaces MAX(0,start - 1),$algebraOutputStream) $collectOutput => string := strconc(fillerSpaces MAX(0,start - 1),op) $outputLines := [string, :$outputLines] PRINC(op,$algebraOutputStream) writeNewline $algebraOutputStream qTSub(u) == subspan second u qTSuper(u) == superspan second u qTWidth(u) == 2 + WIDTH second u remWidth(x) == x isnt [.,:.] => x true => [(first x isnt [.,:.] => first x; true => CAAR x), :[remWidth y for y in 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 == null 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 == string? x => x char "|" = stringChar(s := STRINGIMAGE x, 0) => RPLACSTR(s, 0, 1, "", nil, nil) s superSubSub u == a:= first (u:= rest u) b:= KAR (u := KDR u) e:= KAR KDR KDR KDR u return subspan a + MAX(height b, height e) binomApp(u,x,y,d) == [num,den] := rest u ysub := y - 1 - superspan den ysup := y + 1 + subspan num wden := WIDTH den wnum := WIDTH num w := MAX(wden,wnum) d := APP(den,x+1+ half(w - wden),ysub,d) d := APP(num,x+1+ half(w - wnum),ysup,d) hnum := height num hden := height den w := 1 + w for j in 0..(hnum - 1) repeat d := appChar(specialChar 'vbar,x,y + j,d) d := appChar(specialChar 'vbar,x + w,y + j,d) for j in 1..(hden - 1) repeat d := appChar(specialChar 'vbar,x,y - j,d) d := appChar(specialChar 'vbar,x + w,y - j,d) d := appChar(specialChar 'ulc,x,y + hnum,d) d := appChar(specialChar 'urc,x + w,y + hnum,d) d := appChar(specialChar 'llc,x,y - hden,d) d := appChar(specialChar 'lrc,x + w,y - hden,d) binomSub u == height third u binomSuper u == height second u binomWidth u == 2 + MAX(WIDTH second u, WIDTH third 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 second 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 second 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 second 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 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 := (w - WIDTH a) quo 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 := (w - WIDTH a) quo 2 d := APP(a, x + xoff, y1, d) y2 := y + height b xoff := (w - WIDTH b) quo 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 == newlineIfDisplaying() (u := string? mathPrint1(mathPrintTran u, nil) => PSTRING u; nil) mathPrintTran u == u isnt [.,:.] => u true => for x in tails u repeat x.first := mathPrintTran first x u mathPrint1(x,fg) == if fg then newlineIfDisplaying() maPrin x if fg then newlineIfDisplaying() maPrin u == null u => nil --> if $runTestFlag or $mkTestFlag then $mkTestOutputStack := [copyTree 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 not $collectOutput then writeNewline $algebraOutputStream PRETTYPRINT(form,$algebraOutputStream) form if not $collectOutput then PRETTYPRINT(u,$algebraOutputStream) nil --% Rendering of InputForm $allClassicOps == ["~","#","not","**","^","*","/","rem","quo","+","-","@","::", "pretend"] isUnaryPrefix op == op in '(_~ _# _- _not) primaryForm2String x == x = nil => '"" string? x => x x = $EmptyMode => specialChar 'quad ident? x => x = "$" => '"%" x = "$$" => '"%%" symbolName x x isnt [.,:.] => toString x strconc('"(",inputForm2String x, '")") callForm2String x == x isnt [.,:.] => primaryForm2String x [op,:args] := x member(op,$allClassicOps) => primaryForm2String x #args = 0 => op = "Zero" => '"0" op = "One" => '"1" constructor? op => primaryForm2String op strconc(inputForm2String op, '"()") op = "$elt" => typedForm2String("$", second args, first args) op is ["$elt",t,op'] => typedForm2String("$",[op',:args], t) "strconc"/[inputForm2String op, '"(",:args','")"] where args' := [stringify(a,i) for a in args for i in 0..] stringify(a,i) == i = 0 => inputForm2String a strconc('",",inputForm2String a) typedForm2String(s,x,t) == s = "pretend" => strconc(callForm2String x, '" pretend ", callForm2String t) strconc(callForm2String x, symbolName s, callForm2String t) expForm2String x == x is [op,lhs,rhs] and op in '(** _^) => strconc(expForm2String lhs,'"^", callForm2String rhs) callForm2String x unaryForm2String x == x is [op,arg] and isUnaryPrefix op => strconc(inputForm2String op, inputForm2String arg) expForm2String x multForm2String x == x isnt ["*",lhs,rhs] => unaryForm2String x strconc(multForm2String lhs,'"*", multForm2String rhs) divForm2String x == x isnt ["/",lhs,rhs] => multForm2String x strconc(divForm2String lhs,'"/", expForm2String rhs) remForm2String x == x isnt ["rem",lhs,rhs] => divForm2String x strconc(divForm2String lhs,'" rem ", multForm2String rhs) quoForm2String x == x isnt ["quo",lhs,rhs] => remForm2String x strconc(quoForm2String lhs,'" quo ", remForm2String rhs) plusForm2String x == x isnt ["+",lhs,rhs] => quoForm2String x strconc(plusForm2String lhs,'" + ", plusForm2String rhs) minusForm2String x == x isnt ["-",lhs,rhs] => plusForm2String x strconc(minusForm2String lhs,'" - ", minusForm2String rhs) parms2String x == null x => "()" ident? x => x x is [var] => var if x is ["tuple",:.] then x := rest x paren [parm xs for xs in tails x] where paren l == "strconc"/['"(",:l,'")"] parm xs == null rest xs => first xs strconc(first xs, '", ") inputForm2String x == x isnt [.,:.] => primaryForm2String x [op,:args] := x isUnaryPrefix op and #args = 1 => unaryForm2String x #args = 2 => op in '(** _^) => expForm2String x op = "*" => multForm2String x op = "/" => divForm2String x op = "rem" => remForm2String x op = "quo" => quoForm2String x op = "+" => plusForm2String x op = "-" => minusForm2String x op in '(_@ _:_: pretend) => typedForm2String(op, first args, second args) op = "+->" => strconc(parms2String second x, '" ", first x, '" ", inputForm2String third x) callForm2String x callForm2String x inputForm2OutputForm x == makeSymbol inputForm2String x -- function for turning strings in tex format str2Outform s == parse := ncParseFromString s or systemError '"String for TeX will not parse" parse2Outform parse parse2Outform x == x is [op,:argl] => nargl := [parse2Outform y for y in argl] op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] [op,:nargl] x str2Tex s == outf := str2Outform s val := coerceInt(objNew(wrap outf, '(OutputForm)), '(TexFormat)) val := objValUnwrap val first val.1